This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
https://perl5.git.perl.org / perl5.git / blobdiff
? search:
summary | shortlog | log | commit | commitdiff | tree
raw | inline | side by side
Remove, in the main Makefile, the $(LDLIBPTH) variable from
[perl5.git] / dump.c
diff --git a/dump.c b/dump.c
index 83fd09e..244d064 100644 (file)
--- a/dump.c
+++ b/dump.c
@@ -1,6 +1,7 @@
 /*    dump.c
  *
- *    Copyright (c) 1991-2002, Larry Wall
+ *    Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
+ *    2000, 2001, 2002, 2003, 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.
@@ -194,11 +195,23 @@ Perl_sv_peek(pTHX_ SV *sv)
        sv_catpv(t, "(");
        unref++;
     }
-    else if (DEBUG_R_TEST_ && SvREFCNT(sv) > 1) {
-       Perl_sv_catpvf(aTHX_ t, "<%"UVuf">", (UV)SvREFCNT(sv));
+    else if (DEBUG_R_TEST_) {
+       int is_tmp = 0;
+       I32 ix;
+       /* is this SV on the tmps stack? */
+       for (ix=PL_tmps_ix; ix>=0; ix--) {
+           if (PL_tmps_stack[ix] == sv) {
+               is_tmp = 1;
+               break;
+           }
+       }
+       if (SvREFCNT(sv) > 1)
+           Perl_sv_catpvf(aTHX_ t, "<%"UVuf"%s>", (UV)SvREFCNT(sv),
+                   is_tmp ? "T" : "");
+       else if (is_tmp)
+           sv_catpv(t, "<T>");
     }
 
-
     if (SvROK(sv)) {
        sv_catpv(t, "\\");
        if (SvCUR(t) + unref > 10) {
@@ -461,8 +474,6 @@ Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, OP *o)
         else if (o->op_type == OP_AASSIGN) {
            if (o->op_private & OPpASSIGN_COMMON)
                sv_catpv(tmpsv, ",COMMON");
-           if (o->op_private & OPpASSIGN_HASH)
-               sv_catpv(tmpsv, ",HASH");
        }
        else if (o->op_type == OP_SASSIGN) {
            if (o->op_private & OPpASSIGN_BACKWARDS)
@@ -634,7 +645,7 @@ Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, OP *o)
        break;
     case OP_CONST:
     case OP_METHOD_NAMED:
-       Perl_dump_indent(aTHX_ level, file, "SV = %s\n", SvPEEK(cSVOPo->op_sv));
+       Perl_dump_indent(aTHX_ level, file, "SV = %s\n", SvPEEK(cSVOPo_sv));
        break;
     case OP_SETSTATE:
     case OP_NEXTSTATE:
@@ -770,6 +781,8 @@ static struct { char type; char *name; } magic_names[] = {
        { PERL_MAGIC_taint,          "taint(t)" },
        { PERL_MAGIC_uvar_elem,      "uvar_elem(v)" },
        { PERL_MAGIC_vec,            "vec(v)" },
+       { PERL_MAGIC_vstring,        "vstring(V)" },
+       { PERL_MAGIC_utf8,           "utf8(w)" },
        { PERL_MAGIC_substr,         "substr(x)" },
        { PERL_MAGIC_defelem,        "defelem(y)" },
        { PERL_MAGIC_ext,            "ext(~)" },
@@ -813,6 +826,7 @@ Perl_do_magic_dump(pTHX_ I32 level, PerlIO *file, MAGIC *mg, I32 nest, I32 maxne
            else if (v == &PL_vtbl_amagic)     s = "amagic";
            else if (v == &PL_vtbl_amagicelem) s = "amagicelem";
            else if (v == &PL_vtbl_backref)    s = "backref";
+           else if (v == &PL_vtbl_utf8)       s = "utf8";
            if (s)
                Perl_dump_indent(aTHX_ level, file, "    MG_VIRTUAL = &PL_vtbl_%s\n", s);
            else
@@ -843,13 +857,15 @@ Perl_do_magic_dump(pTHX_ I32 level, PerlIO *file, MAGIC *mg, I32 nest, I32 maxne
 
         if (mg->mg_flags) {
             Perl_dump_indent(aTHX_ level, file, "    MG_FLAGS = 0x%02X\n", mg->mg_flags);
-           if (mg->mg_flags & MGf_TAINTEDDIR)
+           if (mg->mg_type == PERL_MAGIC_envelem &&
+               mg->mg_flags & MGf_TAINTEDDIR)
                Perl_dump_indent(aTHX_ level, file, "      TAINTEDDIR\n");
            if (mg->mg_flags & MGf_REFCOUNTED)
                Perl_dump_indent(aTHX_ level, file, "      REFCOUNTED\n");
             if (mg->mg_flags & MGf_GSKIP)
                Perl_dump_indent(aTHX_ level, file, "      GSKIP\n");
-           if (mg->mg_flags & MGf_MINMATCH)
+           if (mg->mg_type == PERL_MAGIC_regex_global &&
+               mg->mg_flags & MGf_MINMATCH)
                Perl_dump_indent(aTHX_ level, file, "      MINMATCH\n");
         }
        if (mg->mg_obj) {
@@ -862,9 +878,11 @@ Perl_do_magic_dump(pTHX_ I32 level, PerlIO *file, MAGIC *mg, I32 nest, I32 maxne
         if (mg->mg_ptr) {
            Perl_dump_indent(aTHX_ level, file, "    MG_PTR = 0x%"UVxf, PTR2UV(mg->mg_ptr));
            if (mg->mg_len >= 0) {
-               SV *sv = newSVpvn("", 0);
-                PerlIO_printf(file, " %s", pv_display(sv, mg->mg_ptr, mg->mg_len, 0, pvlim));
-               SvREFCNT_dec(sv);
+               if (mg->mg_type != PERL_MAGIC_utf8) {
+                   SV *sv = newSVpvn("", 0);
+                   PerlIO_printf(file, " %s", pv_display(sv, mg->mg_ptr, mg->mg_len, 0, pvlim));
+                   SvREFCNT_dec(sv);
+               }
             }
            else if (mg->mg_len == HEf_SVKEY) {
                PerlIO_puts(file, " => HEf_SVKEY\n");
@@ -875,6 +893,18 @@ Perl_do_magic_dump(pTHX_ I32 level, PerlIO *file, MAGIC *mg, I32 nest, I32 maxne
                PerlIO_puts(file, " ???? - please notify IZ");
             PerlIO_putc(file, '\n');
         }
+       if (mg->mg_type == PERL_MAGIC_utf8) {
+           STRLEN *cache = (STRLEN *) mg->mg_ptr;
+           if (cache) {
+               IV i;
+               for (i = 0; i < PERL_MAGIC_UTF8_CACHESIZE; i++)
+                   Perl_dump_indent(aTHX_ level, file,
+                                    "      %2"IVdf": %"UVuf" -> %"UVuf"\n",
+                                    i,
+                                    (UV)cache[i * 2],
+                                    (UV)cache[i * 2 + 1]);
+           }
+       }
     }
 }
 
@@ -925,7 +955,6 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo
     char *s;
     U32 flags;
     U32 type;
-    STRLEN n_a;
 
     if (!sv) {
        Perl_dump_indent(aTHX_ level, file, "SV = 0\n");
@@ -941,7 +970,7 @@ 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_PADBUSY)   sv_catpv(d, "PADBUSY,");
+    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 & SVs_TEMP)      sv_catpv(d, "TEMP,");
@@ -980,6 +1009,8 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo
        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,");
+       if (CvASSERTION(sv))    sv_catpv(d, "ASSERTION,");
        break;
     case SVt_PVHV:
        if (HvSHAREKEYS(sv))    sv_catpv(d, "SHAREKEYS,");
@@ -1020,7 +1051,7 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo
                                sv_catpv(d, "TYPED,");
        break;
     }
-    if (SvPOK(sv) && SvUTF8(sv))
+    if ((SvPOK(sv) || SvPOKp(sv)) && SvUTF8(sv))
         sv_catpv(d, "UTF8");
 
     if (*(SvEND(d) - 1) == ',')
@@ -1085,12 +1116,22 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo
        return;
     }
     if (type >= SVt_PVIV || type == SVt_IV) {
-       if (SvIsUV(sv))
+       if (SvIsUV(sv)
+#ifdef PERL_COPY_ON_WRITE
+                      || SvIsCOW(sv)
+#endif
+                                    )
            Perl_dump_indent(aTHX_ level, file, "  UV = %"UVuf, (UV)SvUVX(sv));
        else
            Perl_dump_indent(aTHX_ level, file, "  IV = %"IVdf, (IV)SvIVX(sv));
        if (SvOOK(sv))
            PerlIO_printf(file, "  (OFFSET)");
+#ifdef PERL_COPY_ON_WRITE
+       if (SvIsCOW_shared_hash(sv))
+           PerlIO_printf(file, "  (HASH)");
+       else if (SvIsCOW_normal(sv))
+           PerlIO_printf(file, "  (COW from 0x%"UVxf")", (UV)SvUVX(sv));
+#endif
        PerlIO_putc(file, '\n');
     }
     if (type >= SVt_PVNV || type == SVt_NV) {
@@ -1107,8 +1148,6 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo
        Perl_dump_indent(aTHX_ level, file, "  RV = 0x%"UVxf"\n", PTR2UV(SvRV(sv)));
        if (nest < maxnest)
            do_sv_dump(level+1, file, SvRV(sv), nest+1, maxnest, dumpops, pvlim);
-       SvREFCNT_dec(d);
-       return;
     }
     if (type < SVt_PV) {
        SvREFCNT_dec(d);
@@ -1141,8 +1180,9 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo
        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)));
-       /* XXX level+1 ??? */
-       do_sv_dump(level, file, LvTARG(sv), nest+1, maxnest, dumpops, pvlim);
+       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)));
@@ -1263,7 +1303,7 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo
        break;
     case SVt_PVCV:
        if (SvPOK(sv))
-           Perl_dump_indent(aTHX_ level, file, "  PROTOTYPE = \"%s\"\n", SvPV(sv,n_a));
+           Perl_dump_indent(aTHX_ level, file, "  PROTOTYPE = \"%s\"\n", SvPV_nolen(sv));
        /* FALL THROUGH */
     case SVt_PVFM:
        do_hv_dump(level, file, "  COMP_STASH", CvSTASH(sv));
@@ -1277,34 +1317,13 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo
        do_gvgv_dump(level, file, "  GVGV::GV", CvGV(sv));
        Perl_dump_indent(aTHX_ level, file, "  FILE = \"%s\"\n", CvFILE(sv));
        Perl_dump_indent(aTHX_ level, file, "  DEPTH = %"IVdf"\n", (IV)CvDEPTH(sv));
-#ifdef USE_5005THREADS
-       Perl_dump_indent(aTHX_ level, file, "  MUTEXP = 0x%"UVxf"\n", PTR2UV(CvMUTEXP(sv)));
-       Perl_dump_indent(aTHX_ level, file, "  OWNER = 0x%"UVxf"\n",  PTR2UV(CvOWNER(sv)));
-#endif /* USE_5005THREADS */
        Perl_dump_indent(aTHX_ level, file, "  FLAGS = 0x%"UVxf"\n", (UV)CvFLAGS(sv));
+       Perl_dump_indent(aTHX_ level, file, "  OUTSIDE_SEQ = %"UVuf"\n", (UV)CvOUTSIDE_SEQ(sv));
        if (type == SVt_PVFM)
            Perl_dump_indent(aTHX_ level, file, "  LINES = %"IVdf"\n", (IV)FmLINES(sv));
        Perl_dump_indent(aTHX_ level, file, "  PADLIST = 0x%"UVxf"\n", PTR2UV(CvPADLIST(sv)));
-       if (nest < maxnest && CvPADLIST(sv)) {
-           AV* padlist = CvPADLIST(sv);
-           AV* pad_name = (AV*)*av_fetch(padlist, 0, FALSE);
-           AV* pad = (AV*)*av_fetch(padlist, 1, FALSE);
-           SV** pname = AvARRAY(pad_name);
-           SV** ppad = AvARRAY(pad);
-           I32 ix;
-
-           for (ix = 1; ix <= AvFILL(pad_name); ix++) {
-               if (SvPOK(pname[ix]))
-                   Perl_dump_indent(aTHX_ level,
-                               /* %5d below is enough whitespace. */
-                               file,
-                               "%5d. 0x%"UVxf" (%s\"%s\" %"IVdf"-%"IVdf")\n",
-                               (int)ix, PTR2UV(ppad[ix]),
-                               SvFAKE(pname[ix]) ? "FAKE " : "",
-                               SvPVX(pname[ix]),
-                               (IV)SvNVX(pname[ix]),
-                               (IV)SvIVX(pname[ix]));
-           }
+       if (nest < maxnest) {
+           do_dump_pad(level+1, file, CvPADLIST(sv), 0);
        }
        {
            CV *outside = CvOUTSIDE(sv);
@@ -1416,7 +1435,6 @@ Perl_debop(pTHX_ OP *o)
     AV *padlist, *comppad;
     CV *cv;
     SV *sv;
-    STRLEN n_a;
 
     if (CopSTASH_eq(PL_curcop, PL_debstash) && !DEBUG_J_TEST_)
        return 0;
@@ -1431,7 +1449,7 @@ Perl_debop(pTHX_ OP *o)
        if (cGVOPo_gv) {
            sv = NEWSV(0,0);
            gv_fullname3(sv, cGVOPo_gv, Nullch);
-           PerlIO_printf(Perl_debug_log, "(%s)", SvPV(sv, n_a));
+           PerlIO_printf(Perl_debug_log, "(%s)", SvPV_nolen(sv));
            SvREFCNT_dec(sv);
        }
        else
Unnamed repository; edit this file 'description' to name the repository.