dump.c: handle GV being really a ref to a CV

RT #129285

These days a 'GV' can actually just be a ref to a CV when the only thing
that would be stored in the glob is a CV. Update S_do_op_dump_bar() to
handle this. Formerly it would trigger an assert on a non-threaded build.

In fact, incorporate the fixed logic into a static function,
S_gv_display(), that is shared by both S_do_op_dump_bar() and
Perl_debop(); so both

    perl -Dx

and

    perl -Dt

get the benefit.

Also for the -Dx case, make it display the raw address of the GV too.

diff --git a/dump.c b/dump.c
index 54a4fb5..ce63f35 100644 (file)
--- a/dump.c
+++ b/dump.c
@@ -731,6 +731,37 @@ Perl_dump_eval(pTHX)
 }
 
 
+/* returns a temp SV displaying the name of a GV. Handles the case where
+ * a GV is in fact a ref to a CV */
+
+static SV *
+S_gv_display(pTHX_ GV *gv)
+{
+    SV * const name = newSV(0);
+    if (gv) {
+        SV * const raw = newSVpvs_flags("", SVs_TEMP);
+        STRLEN len;
+        const char * rawpv;
+
+        if (isGV_with_GP(gv))
+            gv_fullname3(raw, gv, NULL);
+        else {
+            assert(SvROK(gv));
+            assert(SvTYPE(SvRV(gv)) == SVt_PVCV);
+            Perl_sv_catpvf(aTHX_ raw, "cv ref: %s",
+                    SvPV_nolen_const(cv_name((CV *)SvRV(gv), name, 0)));
+        }
+        rawpv = SvPV_const(raw, len);
+        generic_pv_escape(name, rawpv, len, SvUTF8(raw));
+    }
+    else
+        sv_catpvs(name, "(NULL)");
+
+    return name;
+}
+
+
+
 /* forward decl */
 static void
 S_do_op_dump_bar(pTHX_ I32 level, UV bar, PerlIO *file, const OP *o);
@@ -1073,19 +1104,9 @@ S_do_op_dump_bar(pTHX_ I32 level, UV bar, PerlIO *file, const OP *o)
        S_opdump_indent(aTHX_ o, level, bar, file,
                         "PADIX = %" IVdf "\n", (IV)cPADOPo->op_padix);
 #else
-        if (cSVOPo->op_sv) {
-            STRLEN len;
-            const char * name;
-            SV * const tmpsv  = newSVpvs_flags("", SVs_TEMP);
-            SV * const tmpsv2 = newSVpvs_flags("", SVs_TEMP);
-
-            gv_fullname3(tmpsv, MUTABLE_GV(cSVOPo->op_sv), NULL);
-            name = SvPV_const(tmpsv, len);
-            S_opdump_indent(aTHX_ o, level, bar, file, "GV = %s\n",
-                   generic_pv_escape( tmpsv2, name, len, SvUTF8(tmpsv)));
-        }
-        else
-            S_opdump_indent(aTHX_ o, level, bar, file, "GV = NULL\n");
+        S_opdump_indent(aTHX_ o, level, bar, file,
+            "GV = %" SVf " (0x%" UVxf ")\n",
+            SVfARG(S_gv_display(aTHX_ cGVOPo_gv)), PTR2UV(cGVOPo_gv));
 #endif
        break;
 
@@ -2666,22 +2687,8 @@ Perl_debop(pTHX_ const OP *o)
        break;
     case OP_GVSV:
     case OP_GV:
-       if (cGVOPo_gv && isGV(cGVOPo_gv)) {
-           SV * const sv = newSV(0);
-           gv_fullname3(sv, cGVOPo_gv, NULL);
-           PerlIO_printf(Perl_debug_log, "(%s)", SvPV_nolen_const(sv));
-           SvREFCNT_dec_NN(sv);
-       }
-       else if (cGVOPo_gv) {
-           SV * const sv = newSV(0);
-           assert(SvROK(cGVOPo_gv));
-           assert(SvTYPE(SvRV(cGVOPo_gv)) == SVt_PVCV);
-           PerlIO_printf(Perl_debug_log, "(cv ref: %s)",
-                   SvPV_nolen_const(cv_name((CV *)SvRV(cGVOPo_gv),sv,0)));
-           SvREFCNT_dec_NN(sv);
-       }
-       else
-           PerlIO_printf(Perl_debug_log, "(NULL)");
+        PerlIO_printf(Perl_debug_log, "(%" SVf ")",
+                SVfARG(S_gv_display(aTHX_ cGVOPo_gv)));
        break;
 
     case OP_PADSV:

diff --git a/ext/Devel-Peek/t/Peek.t b/ext/Devel-Peek/t/Peek.t
index fa25b48..2b1ed5d 100644 (file)
--- a/ext/Devel-Peek/t/Peek.t
+++ b/ext/Devel-Peek/t/Peek.t
@@ -1490,7 +1490,7 @@ dumpindent is 4 at -e line 1.
                      GV_OR_PADIX
 EODUMP
 
-    $e =~ s/GV_OR_PADIX/$threads ? "PADIX = 2" : "GV = t::DumpProg"/e;
+    $e =~ s/GV_OR_PADIX/$threads ? "PADIX = 2" : "GV = t::DumpProg (0xNNN)"/e;
     $e =~ s/SVOP/PADOP/g if $threads;
     my $out = t::runperl
                  switches => ['-Ilib'],
@@ -1498,7 +1498,7 @@ EODUMP
                  stderr=>1;
     $out =~ s/ *SEQ = .*\n//;
     $out =~ s/0x[0-9a-f]{2,}\]/${1}0xNNN]/g;
-    $out =~ s/0x[0-9a-f]{2,}\) ===/0xNNN) ===/g;
+    $out =~ s/\(0x[0-9a-f]{3,}\)/(0xNNN)/g;
     is $out, $e, "DumpProg() has no 'Attempt to free X prematurely' warning";
 }
 done_testing();