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
Porting/sync-with-cpan: 5.12 compatibility
[perl5.git] / dump.c
diff --git a/dump.c b/dump.c
index 9edc8bf..a2c0bbc 100644 (file)
--- a/dump.c
+++ b/dump.c
@@ -369,7 +369,9 @@ Perl_sv_peek(pTHX_ SV *sv)
        sv_catpv(t, "WILD");
        goto finish;
     }
-    else if (sv == &PL_sv_undef || sv == &PL_sv_no || sv == &PL_sv_yes || sv == &PL_sv_placeholder) {
+    else if (  sv == &PL_sv_undef || sv == &PL_sv_no || sv == &PL_sv_yes
+            || sv == &PL_sv_zero || sv == &PL_sv_placeholder)
+    {
        if (sv == &PL_sv_undef) {
            sv_catpv(t, "SV_UNDEF");
            if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
@@ -398,6 +400,17 @@ Perl_sv_peek(pTHX_ SV *sv)
                SvNVX(sv) == 1.0)
                goto finish;
        }
+       else if (sv == &PL_sv_zero) {
+           sv_catpv(t, "SV_ZERO");
+           if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
+                                SVs_GMG|SVs_SMG|SVs_RMG)) &&
+               !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
+                                 SVp_POK|SVp_NOK)) &&
+               SvCUR(sv) == 1 &&
+               SvPVX_const(sv) && *SvPVX_const(sv) == '0' &&
+               SvNVX(sv) == 0.0)
+               goto finish;
+       }
        else {
            sv_catpv(t, "SV_PLACEHOLDER");
            if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
@@ -565,7 +578,10 @@ S_opdump_indent(pTHX_ const OP *o, I32 level, UV bar, PerlIO *file,
         /* output preceding blank line */
         PerlIO_puts(file, "     ");
         for (i = level-1; i >= 0; i--)
-            PerlIO_puts(file,  i == 0 || (bar & (1 << i)) ?  "|   " : "    ");
+            PerlIO_puts(file,  (   i == 0
+                                || (i < UVSIZE*8 && (bar & ((UV)1 << i)))
+                               )
+                                    ?  "|   " : "    ");
         PerlIO_puts(file, "\n");
 
         /* output sequence number */
@@ -684,27 +700,33 @@ Perl_dump_sub(pTHX_ const GV *gv)
 void
 Perl_dump_sub_perl(pTHX_ const GV *gv, bool justperl)
 {
-    STRLEN len;
-    SV * const sv = newSVpvs_flags("", SVs_TEMP);
-    SV *tmpsv;
-    const char * name;
+    CV *cv;
 
     PERL_ARGS_ASSERT_DUMP_SUB_PERL;
 
-    if (justperl && (CvISXSUB(GvCV(gv)) || !CvROOT(GvCV(gv))))
+    cv = isGV_with_GP(gv) ? GvCV(gv) :
+           (assert(SvROK((SV*)gv)), (CV*)SvRV((SV*)gv));
+    if (justperl && (CvISXSUB(cv) || !CvROOT(cv)))
        return;
 
-    tmpsv = newSVpvs_flags("", SVs_TEMP);
-    gv_fullname3(sv, gv, NULL);
-    name = SvPV_const(sv, len);
-    Perl_dump_indent(aTHX_ 0, Perl_debug_log, "\nSUB %s = ",
-                     generic_pv_escape(tmpsv, name, len, SvUTF8(sv)));
-    if (CvISXSUB(GvCV(gv)))
+    if (isGV_with_GP(gv)) {
+       SV * const namesv = newSVpvs_flags("", SVs_TEMP);
+       SV *escsv = newSVpvs_flags("", SVs_TEMP);
+       const char *namepv;
+       STRLEN namelen;
+       gv_fullname3(namesv, gv, NULL);
+       namepv = SvPV_const(namesv, namelen);
+       Perl_dump_indent(aTHX_ 0, Perl_debug_log, "\nSUB %s = ",
+                    generic_pv_escape(escsv, namepv, namelen, SvUTF8(namesv)));
+    } else {
+       Perl_dump_indent(aTHX_ 0, Perl_debug_log, "\nSUB = ");
+    }
+    if (CvISXSUB(cv))
        Perl_dump_indent(aTHX_ 0, Perl_debug_log, "(xsub 0x%" UVxf " %d)\n",
-           PTR2UV(CvXSUB(GvCV(gv))),
-           (int)CvXSUBANY(GvCV(gv)).any_i32);
-    else if (CvROOT(GvCV(gv)))
-       op_dump(CvROOT(GvCV(gv)));
+           PTR2UV(CvXSUB(cv)),
+           (int)CvXSUBANY(cv).any_i32);
+    else if (CvROOT(cv))
+       op_dump(CvROOT(cv));
     else
        Perl_dump_indent(aTHX_ 0, Perl_debug_log, "<undef>\n");
 }
@@ -924,7 +946,7 @@ const struct flag_to_name op_flags_names[] = {
 
 
 /* indexed by enum OPclass */
-const char * op_class_names[] = {
+const char * const op_class_names[] = {
     "NULL",
     "OP",
     "UNOP",
@@ -1221,21 +1243,22 @@ S_do_op_dump_bar(pTHX_ I32 level, UV bar, PerlIO *file, const OP *o)
     case OP_REDO:
        if (o->op_flags & (OPf_SPECIAL|OPf_STACKED|OPf_KIDS))
            break;
-       /* FALLTHROUGH */
-    case OP_TRANS:
-    case OP_TRANSR:
-       if (   (o->op_type == OP_TRANS || o->op_type == OP_TRANSR)
-            && (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)))
-            break;
-
         {
             SV * const label = newSVpvs_flags("", SVs_TEMP);
             generic_pv_escape(label, cPVOPo->op_pv, strlen(cPVOPo->op_pv), 0);
             S_opdump_indent(aTHX_ o, level, bar, file,
                             "PV = \"%" SVf "\" (0x%" UVxf ")\n",
                             SVfARG(label), PTR2UV(cPVOPo->op_pv));
+            break;
         }
 
+    case OP_TRANS:
+    case OP_TRANSR:
+            S_opdump_indent(aTHX_ o, level, bar, file,
+                            "PV = 0x%" UVxf "\n",
+                            PTR2UV(cPVOPo->op_pv));
+            break;
+
 
     default:
        break;
@@ -1816,7 +1839,12 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo
                 PerlIO_printf(file, "\n");
             }
            Perl_dump_indent(aTHX_ level, file, "  CUR = %" IVdf "\n", (IV)SvCUR(sv));
-           if (!re)
+           if (re && type == SVt_PVLV)
+                /* LV-as-REGEXP usurps len field to store pointer to
+                 * regexp struct */
+               Perl_dump_indent(aTHX_ level, file, "  REGEXP = 0x%" UVxf "\n",
+                   PTR2UV(((XPV*)SvANY(sv))->xpv_len_u.xpvlenu_rx));
+            else
                Perl_dump_indent(aTHX_ level, file, "  LEN = %" IVdf "\n",
                                       (IV)SvLEN(sv));
 #ifdef PERL_COPY_ON_WRITE
@@ -1886,7 +1914,7 @@ Perl_do_sv_dump(pTHX_ I32 level, PerlIO *file, SV *sv, I32 nest, I32 maxnest, bo
                              (UV)aux->xhv_aux_flags);
         }
        Perl_dump_indent(aTHX_ level, file, "  ARRAY = 0x%" UVxf, PTR2UV(HvARRAY(sv)));
-       usedkeys = HvUSEDKEYS(sv);
+       usedkeys = HvUSEDKEYS(MUTABLE_HV(sv));
        if (HvARRAY(sv) && usedkeys) {
            /* Show distribution of HEs in the ARRAY */
            int freq[200];
@@ -2406,16 +2434,30 @@ Perl_sv_dump(pTHX_ SV *sv)
 int
 Perl_runops_debug(pTHX)
 {
+#if defined DEBUGGING && !defined DEBUGGING_RE_ONLY
+    SSize_t orig_stack_hwm = PL_curstackinfo->si_stack_hwm;
+
+    PL_curstackinfo->si_stack_hwm = PL_stack_sp - PL_stack_base;
+#endif
+
     if (!PL_op) {
        Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING), "NULL OP IN RUN");
        return 0;
     }
-
     DEBUG_l(Perl_deb(aTHX_ "Entering new RUNOPS level\n"));
     do {
 #ifdef PERL_TRACE_OPS
         ++PL_op_exec_cnt[PL_op->op_type];
 #endif
+#if defined DEBUGGING && !defined DEBUGGING_RE_ONLY
+        if (PL_curstackinfo->si_stack_hwm < PL_stack_sp - PL_stack_base)
+            Perl_croak_nocontext(
+                "panic: previous op failed to extend arg stack: "
+                "base=%p, sp=%p, hwm=%p\n",
+                    PL_stack_base, PL_stack_sp,
+                    PL_stack_base + PL_curstackinfo->si_stack_hwm);
+        PL_curstackinfo->si_stack_hwm = PL_stack_sp - PL_stack_base;
+#endif
        if (PL_debug) {
             ENTER;
             SAVETMPS;
@@ -2445,6 +2487,10 @@ Perl_runops_debug(pTHX)
     DEBUG_l(Perl_deb(aTHX_ "leaving RUNOPS level\n"));
     PERL_ASYNC_CHECK();
 
+#if defined DEBUGGING && !defined DEBUGGING_RE_ONLY
+    if (PL_curstackinfo->si_stack_hwm < orig_stack_hwm)
+        PL_curstackinfo->si_stack_hwm = orig_stack_hwm;
+#endif
     TAINT_NOT;
     return 0;
 }
Unnamed repository; edit this file 'description' to name the repository.