X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/7996736c5ecb6da6273386229ce113837049152c..a80036c632e9a590837ce173395af69d6c7c2ed5:/dump.c

diff --git a/dump.c b/dump.c
index 52a43a9..5f0bef2 100644
--- a/dump.c
+++ b/dump.c
@@ -1,7 +1,7 @@
 /*    dump.c
  *
  *    Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
- *    2000, 2001, 2002, 2003, by Larry Wall and others
+ *    2000, 2001, 2002, 2003, 2004, by Larry Wall and others
  *
  *    You may distribute under the terms of either the GNU General Public
  *    License or the Artistic License, as specified in the README file.
@@ -13,11 +13,20 @@
  * it has not been hard for me to read your mind and memory.'"
  */
 
+/* This file contains utility routines to dump the contents of SV and OP
+ * structures, as used by command-line options like -Dt and -Dx, and
+ * by Devel::Peek.
+ *
+ * It also holds the debugging version of the  runops function.
+ */
+
 #include "EXTERN.h"
 #define PERL_IN_DUMP_C
 #include "perl.h"
 #include "regcomp.h"
 
+static HV *Sequence;
+
 void
 Perl_dump_indent(pTHX_ I32 level, PerlIO *file, const char* pat, ...)
 {
@@ -116,19 +125,17 @@ Perl_pv_display(pTHX_ SV *dsv, char *pv, STRLEN cur, STRLEN len, STRLEN pvlim)
             truncated++;
 	    break;
         }
-        if (isPRINT(*pv)) {
-            switch (*pv) {
-	    case '\t': sv_catpvn(dsv, "\\t", 2);  break;
-	    case '\n': sv_catpvn(dsv, "\\n", 2);  break;
-	    case '\r': sv_catpvn(dsv, "\\r", 2);  break;
-	    case '\f': sv_catpvn(dsv, "\\f", 2);  break;
-	    case '"':  sv_catpvn(dsv, "\\\"", 2); break;
-	    case '\\': sv_catpvn(dsv, "\\\\", 2); break;
-	    default:   sv_catpvn(dsv, pv, 1);     break;
-            }
-        }
-	else {
-	    if (cur && isDIGIT(*(pv+1)))
+	switch (*pv) {
+	case '\t': sv_catpvn(dsv, "\\t", 2);  break;
+	case '\n': sv_catpvn(dsv, "\\n", 2);  break;
+	case '\r': sv_catpvn(dsv, "\\r", 2);  break;
+	case '\f': sv_catpvn(dsv, "\\f", 2);  break;
+	case '"':  sv_catpvn(dsv, "\\\"", 2); break;
+	case '\\': sv_catpvn(dsv, "\\\\", 2); break;
+	default:
+	    if (isPRINT(*pv))
+		sv_catpvn(dsv, pv, 1);
+	    else if (cur && isDIGIT(*(pv+1)))
 		Perl_sv_catpvf(aTHX_ dsv, "\\%03o", (U8)*pv);
 	    else
 		Perl_sv_catpvf(aTHX_ dsv, "\\%o", (U8)*pv);
@@ -392,24 +399,137 @@ Perl_pmop_dump(pTHX_ PMOP *pm)
     do_pmop_dump(0, Perl_debug_log, pm);
 }
 
+/* An op sequencer.  We visit the ops in the order they're to execute. */
+
+STATIC void
+sequence(pTHX_ register OP *o)
+{
+    SV      *op;
+    char    *key;
+    STRLEN   len;
+    static   UV seq;
+    OP      *oldop = 0,
+            *l;
+
+    if (!Sequence)
+	Sequence = newHV();
+
+    if (!o)
+	return;
+
+    op = newSVuv(PTR2UV(o));
+    key = SvPV(op, len);
+    if (hv_exists(Sequence, key, len))
+	return;
+
+    for (; o; o = o->op_next) {
+	op = newSVuv(PTR2UV(o));
+	key = SvPV(op, len);
+	if (hv_exists(Sequence, key, len))
+	    break;
+
+	switch (o->op_type) {
+	case OP_STUB:
+	    if ((o->op_flags & OPf_WANT) != OPf_WANT_LIST) {
+		hv_store(Sequence, key, len, newSVuv(++seq), 0);
+		break;
+	    }
+	    goto nothin;
+	case OP_NULL:
+	    if (oldop && o->op_next)
+		continue;
+	    break;
+	case OP_SCALAR:
+	case OP_LINESEQ:
+	case OP_SCOPE:
+	  nothin:
+	    if (oldop && o->op_next)
+		continue;
+	    hv_store(Sequence, key, len, newSVuv(++seq), 0);
+	    break;
+
+	case OP_MAPWHILE:
+	case OP_GREPWHILE:
+	case OP_AND:
+	case OP_OR:
+	case OP_DOR:
+	case OP_ANDASSIGN:
+	case OP_ORASSIGN:
+	case OP_DORASSIGN:
+	case OP_COND_EXPR:
+	case OP_RANGE:
+	    hv_store(Sequence, key, len, newSVuv(++seq), 0);
+	    for (l = cLOGOPo->op_other; l && l->op_type == OP_NULL; l = l->op_next)
+		;
+	    sequence(aTHX_ l);
+	    break;
+
+	case OP_ENTERLOOP:
+	case OP_ENTERITER:
+	    hv_store(Sequence, key, len, newSVuv(++seq), 0);
+	    for (l = cLOOPo->op_redoop; l && l->op_type == OP_NULL; l = l->op_next)
+		;
+	    sequence(aTHX_ l);
+	    for (l = cLOOPo->op_nextop; l && l->op_type == OP_NULL; l = l->op_next)
+		;
+	    sequence(aTHX_ l);
+	    for (l = cLOOPo->op_lastop; l && l->op_type == OP_NULL; l = l->op_next)
+		;
+	    sequence(aTHX_ l);
+	    break;
+
+	case OP_QR:
+	case OP_MATCH:
+	case OP_SUBST:
+	    hv_store(Sequence, key, len, newSVuv(++seq), 0);
+	    for (l = cPMOPo->op_pmreplstart; l && l->op_type == OP_NULL; l = l->op_next)
+		;
+	    sequence(aTHX_ l);
+	    break;
+
+	case OP_HELEM:
+	    break;
+
+	default:
+	    hv_store(Sequence, key, len, newSVuv(++seq), 0);
+	    break;
+	}
+	oldop = o;
+    }
+}
+
+STATIC UV
+sequence_num(pTHX_ OP *o)
+{
+    SV     *op,
+          **seq;
+    char   *key;
+    STRLEN  len;
+    if (!o) return 0;
+    op = newSVuv(PTR2UV(o));
+    key = SvPV(op, len);
+    seq = hv_fetch(Sequence, key, len, 0);
+    return seq ? SvUV(*seq): 0;
+}
+
 void
 Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, OP *o)
 {
+    UV      seq;
+    sequence(aTHX_ o);
     Perl_dump_indent(aTHX_ level, file, "{\n");
     level++;
-    if (o->op_seq)
-	PerlIO_printf(file, "%-4d", o->op_seq);
+    seq = sequence_num(aTHX_ o);
+    if (seq)
+	PerlIO_printf(file, "%-4"UVf, seq);
     else
 	PerlIO_printf(file, "    ");
     PerlIO_printf(file,
 		  "%*sTYPE = %s  ===> ",
 		  (int)(PL_dumpindent*level-4), "", OP_NAME(o));
-    if (o->op_next) {
-	if (o->op_seq)
-	    PerlIO_printf(file, "%d\n", o->op_next->op_seq);
-	else
-	    PerlIO_printf(file, "(%d)\n", o->op_next->op_seq);
-    }
+    if (o->op_next)
+	PerlIO_printf(file, seq ? "%"UVf"\n" : "(%"UVf")\n",
+				sequence_num(aTHX_ o->op_next));
     else
 	PerlIO_printf(file, "DONE\n");
     if (o->op_targ) {
@@ -624,9 +744,11 @@ Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, OP *o)
 	    if (o->op_private & OPpHUSH_VMSISH)
 		sv_catpv(tmpsv, ",HUSH_VMSISH");
 	}
-	else if (OP_IS_FILETEST_ACCESS(o)) {
-	     if (o->op_private & OPpFT_ACCESS)
-		  sv_catpv(tmpsv, ",FT_ACCESS");
+	else if (PL_check[o->op_type] != MEMBER_TO_FPTR(Perl_ck_ftst)) {
+	    if (OP_IS_FILETEST_ACCESS(o) && o->op_private & OPpFT_ACCESS)
+		sv_catpv(tmpsv, ",FT_ACCESS");
+	    if (o->op_private & OPpFT_STACKED)
+		sv_catpv(tmpsv, ",FT_STACKED");
 	}
 	if (o->op_flags & OPf_MOD && o->op_private & OPpLVAL_INTRO)
 	    sv_catpv(tmpsv, ",INTRO");
@@ -642,22 +764,28 @@ Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, OP *o)
 #ifdef USE_ITHREADS
 	Perl_dump_indent(aTHX_ level, file, "PADIX = %" IVdf "\n", (IV)cPADOPo->op_padix);
 #else
-	if (cSVOPo->op_sv) {
-	    SV *tmpsv = NEWSV(0,0);
-	    STRLEN n_a;
-	    ENTER;
-	    SAVEFREESV(tmpsv);
-	    gv_fullname3(tmpsv, (GV*)cSVOPo->op_sv, Nullch);
-	    Perl_dump_indent(aTHX_ level, file, "GV = %s\n", SvPV(tmpsv, n_a));
-	    LEAVE;
+	if ( ! PL_op->op_flags & OPf_SPECIAL) { /* not lexical */
+	    if (cSVOPo->op_sv) {
+		SV *tmpsv = NEWSV(0,0);
+		STRLEN n_a;
+		ENTER;
+		SAVEFREESV(tmpsv);
+		gv_fullname3(tmpsv, (GV*)cSVOPo->op_sv, Nullch);
+		Perl_dump_indent(aTHX_ level, file, "GV = %s\n", SvPV(tmpsv, n_a));
+		LEAVE;
+	    }
+	    else
+		Perl_dump_indent(aTHX_ level, file, "GV = NULL\n");
 	}
-	else
-	    Perl_dump_indent(aTHX_ level, file, "GV = NULL\n");
 #endif
 	break;
     case OP_CONST:
     case OP_METHOD_NAMED:
+#ifndef USE_ITHREADS
+	/* with ITHREADS, consts are stored in the pad, and the right pad
+	 * may not be active here, so skip */
 	Perl_dump_indent(aTHX_ level, file, "SV = %s\n", SvPEEK(cSVOPo_sv));
+#endif
 	break;
     case OP_SETSTATE:
     case OP_NEXTSTATE:
@@ -675,17 +803,17 @@ Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, OP *o)
     case OP_ENTERLOOP:
 	Perl_dump_indent(aTHX_ level, file, "REDO ===> ");
 	if (cLOOPo->op_redoop)
-	    PerlIO_printf(file, "%d\n", cLOOPo->op_redoop->op_seq);
+	    PerlIO_printf(file, "%"UVf"\n", sequence_num(aTHX_ cLOOPo->op_redoop));
 	else
 	    PerlIO_printf(file, "DONE\n");
 	Perl_dump_indent(aTHX_ level, file, "NEXT ===> ");
 	if (cLOOPo->op_nextop)
-	    PerlIO_printf(file, "%d\n", cLOOPo->op_nextop->op_seq);
+	    PerlIO_printf(file, "%"UVf"\n", sequence_num(aTHX_ cLOOPo->op_nextop));
 	else
 	    PerlIO_printf(file, "DONE\n");
 	Perl_dump_indent(aTHX_ level, file, "LAST ===> ");
 	if (cLOOPo->op_lastop)
-	    PerlIO_printf(file, "%d\n", cLOOPo->op_lastop->op_seq);
+	    PerlIO_printf(file, "%"UVf"\n", sequence_num(aTHX_ cLOOPo->op_lastop));
 	else
 	    PerlIO_printf(file, "DONE\n");
 	break;
@@ -697,7 +825,7 @@ Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, OP *o)
     case OP_AND:
 	Perl_dump_indent(aTHX_ level, file, "OTHER ===> ");
 	if (cLOGOPo->op_other)
-	    PerlIO_printf(file, "%d\n", cLOGOPo->op_other->op_seq);
+	    PerlIO_printf(file, "%"UVf"\n", sequence_num(aTHX_ cLOGOPo->op_other));
 	else
 	    PerlIO_printf(file, "DONE\n");
 	break;
@@ -1003,7 +1131,8 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo
     if (flags & SVf_FAKE)	sv_catpv(d, "FAKE,");
     if (flags & SVf_READONLY)	sv_catpv(d, "READONLY,");
 
-    if (flags & SVf_AMAGIC)	sv_catpv(d, "OVERLOAD,");
+    if (flags & SVf_AMAGIC && type != SVt_PVHV)
+				sv_catpv(d, "OVERLOAD,");
     if (flags & SVp_IOK)	sv_catpv(d, "pIOK,");
     if (flags & SVp_NOK)	sv_catpv(d, "pNOK,");
     if (flags & SVp_POK)	sv_catpv(d, "pPOK,");
@@ -1029,8 +1158,9 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo
 	if (HvSHAREKEYS(sv))	sv_catpv(d, "SHAREKEYS,");
 	if (HvLAZYDEL(sv))	sv_catpv(d, "LAZYDEL,");
 	if (HvHASKFLAGS(sv))	sv_catpv(d, "HASKFLAGS,");
+	if (HvREHASH(sv))	sv_catpv(d, "REHASH,");
 	break;
-    case SVt_PVGV:
+    case SVt_PVGV: case SVt_PVLV:
 	if (GvINTRO(sv))	sv_catpv(d, "INTRO,");
 	if (GvMULTI(sv))	sv_catpv(d, "MULTI,");
 	if (GvUNIQUE(sv))       sv_catpv(d, "UNIQUE,");
@@ -1166,7 +1296,7 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo
 	SvREFCNT_dec(d);
 	return;
     }
-    if (type <= SVt_PVLV) {
+    if (type <= SVt_PVLV && type != SVt_PVGV) {
 	if (SvPVX(sv)) {
 	    Perl_dump_indent(aTHX_ level, file,"  PV = 0x%"UVxf" ", PTR2UV(SvPVX(sv)));
 	    if (SvOOK(sv))
@@ -1188,15 +1318,6 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo
 	    do_hv_dump(level, file, "  STASH", SvSTASH(sv));
     }
     switch (type) {
-    case SVt_PVLV:
-	Perl_dump_indent(aTHX_ level, file, "  TYPE = %c\n", LvTYPE(sv));
-	Perl_dump_indent(aTHX_ level, file, "  TARGOFF = %"IVdf"\n", (IV)LvTARGOFF(sv));
-	Perl_dump_indent(aTHX_ level, file, "  TARGLEN = %"IVdf"\n", (IV)LvTARGLEN(sv));
-	Perl_dump_indent(aTHX_ level, file, "  TARG = 0x%"UVxf"\n", PTR2UV(LvTARG(sv)));
-	if (LvTYPE(sv) != 't' && LvTYPE(sv) != 'T')
-	    do_sv_dump(level+1, file, LvTARG(sv), nest+1, maxnest,
-		    dumpops, pvlim);
-	break;
     case SVt_PVAV:
 	Perl_dump_indent(aTHX_ level, file, "  ARRAY = 0x%"UVxf, PTR2UV(AvARRAY(sv)));
 	if (AvARRAY(sv) != AvALLOC(sv)) {
@@ -1308,6 +1429,8 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo
 		Perl_dump_indent(aTHX_ level+1, file, "Elt %s ", pv_display(d, keypv, len, 0, pvlim));
 		if (SvUTF8(keysv))
 		    PerlIO_printf(file, "[UTF8 \"%s\"] ", sv_uni_display(d, keysv, 8 * sv_len_utf8(keysv), UNI_DISPLAY_QQ));
+		if (HeKREHASH(he))
+		    PerlIO_printf(file, "[REHASH] ");
 		PerlIO_printf(file, "HASH = 0x%"UVxf"\n", (UV)hash);
 		do_sv_dump(level+1, file, elt, nest+1, maxnest, dumpops, pvlim);
 	    }
@@ -1321,7 +1444,7 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo
     case SVt_PVFM:
 	do_hv_dump(level, file, "  COMP_STASH", CvSTASH(sv));
 	if (CvSTART(sv))
-	    Perl_dump_indent(aTHX_ level, file, "  START = 0x%"UVxf" ===> %"IVdf"\n", PTR2UV(CvSTART(sv)), (IV)CvSTART(sv)->op_seq);
+	    Perl_dump_indent(aTHX_ level, file, "  START = 0x%"UVxf" ===> %"IVdf"\n", PTR2UV(CvSTART(sv)), (IV)sequence_num(aTHX_ CvSTART(sv)));
 	Perl_dump_indent(aTHX_ level, file, "  ROOT = 0x%"UVxf"\n", PTR2UV(CvROOT(sv)));
         if (CvROOT(sv) && dumpops)
 	    do_op_dump(level+1, file, CvROOT(sv));
@@ -1351,7 +1474,16 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo
 	if (nest < maxnest && (CvCLONE(sv) || CvCLONED(sv)))
 	    do_sv_dump(level+1, file, (SV*)CvOUTSIDE(sv), nest+1, maxnest, dumpops, pvlim);
 	break;
-    case SVt_PVGV:
+    case SVt_PVGV: case SVt_PVLV:
+    if (type == SVt_PVLV) {
+        Perl_dump_indent(aTHX_ level, file, "  TYPE = %c\n", LvTYPE(sv));
+        Perl_dump_indent(aTHX_ level, file, "  TARGOFF = %"IVdf"\n", (IV)LvTARGOFF(sv));
+        Perl_dump_indent(aTHX_ level, file, "  TARGLEN = %"IVdf"\n", (IV)LvTARGLEN(sv));
+        Perl_dump_indent(aTHX_ level, file, "  TARG = 0x%"UVxf"\n", PTR2UV(LvTARG(sv)));
+        if (LvTYPE(sv) != 't' && LvTYPE(sv) != 'T')
+            do_sv_dump(level+1, file, LvTARG(sv), nest+1, maxnest,
+                dumpops, pvlim);
+    }
 	Perl_dump_indent(aTHX_ level, file, "  NAME = \"%s\"\n", GvNAME(sv));
 	Perl_dump_indent(aTHX_ level, file, "  NAMELEN = %"IVdf"\n", (IV)GvNAMELEN(sv));
 	do_hv_dump (level, file, "  GvSTASH", GvSTASH(sv));
@@ -1415,6 +1547,7 @@ Perl_runops_debug(pTHX)
 	return 0;
     }
 
+    DEBUG_l(Perl_deb(aTHX_ "Entering new RUNOPS level\n"));
     do {
 	PERL_ASYNC_CHECK();
 	if (PL_debug) {
@@ -1437,6 +1570,7 @@ Perl_runops_debug(pTHX)
 	    if (DEBUG_P_TEST_) debprof(PL_op);
 	}
     } while ((PL_op = CALL_FPTR(PL_op->op_ppaddr)(aTHX)));
+    DEBUG_l(Perl_deb(aTHX_ "leaving RUNOPS level\n"));
 
     TAINT_NOT;
     return 0;