Inline Devel::Peek::Dump; allow Dump %hash etc.

This commit makes Devel::Peek::Dump modify the op tree to allow it to
dump arrays and hashes directly via Dump @array and Dump %hash.  It
also puts other operators in rvalue context, allowing the return value
of rvalue substr for instance to be dumped, making Devel::Peek more
useful as a debugging tool.

Since a future commit (to fix the rest of #78194) is likely to make
pp_entersub copy PADTMPs (operator return values) for XSUBs (it
already happens for Perl subs as of b479c9f2a), to the detriment of
Devel::Peek’s usefulness, I also made it inline Dump as a custom op.

This does introduce a backward-incompatible change, in that both argu-
ments to Dump are now in scalar context, and the number of arguments
is checked at compile time instead of run time (still run time for
&Dump(...)), but I think it is worth it.

2 files changed, 174 insertions, 13 deletions

diff --git a/ext/Devel-Peek/Peek.xs b/ext/Devel-Peek/Peek.xs
index 4c5f974e72..1ea7f8fed9 100644
--- a/ext/Devel-Peek/Peek.xs
+++ b/ext/Devel-Peek/Peek.xs
@@ -323,6 +323,95 @@ mstats2hash(SV *sv, SV *rv, int level)
 	(SvROK(cv) && (SvTYPE(SvRV(cv))==SVt_PVCV)	\
 	 ? SvREFCNT_inc(CvGV((CV*)SvRV(cv))) : &PL_sv_undef)
 
+static void
+S_do_dump(pTHX_ SV *const sv, I32 lim)
+{
+    dVAR;
+    SV *pv_lim_sv = perl_get_sv("Devel::Peek::pv_limit", 0);
+    const STRLEN pv_lim = pv_lim_sv ? SvIV(pv_lim_sv) : 0;
+    SV *dumpop = perl_get_sv("Devel::Peek::dump_ops", 0);
+    const U16 save_dumpindent = PL_dumpindent;
+    PL_dumpindent = 2;
+    do_sv_dump(0, Perl_debug_log, sv, 0, lim,
+	       (bool)(dumpop && SvTRUE(dumpop)), pv_lim);
+    PL_dumpindent = save_dumpindent;
+}
+
+static OP *
+S_pp_dump(pTHX)
+{
+    dSP;
+    const I32 lim = PL_op->op_private == 2 ? (I32)POPi : 4;
+    dPOPss;
+    S_do_dump(aTHX_ sv, lim);
+    RETPUSHUNDEF;
+}
+
+static OP *
+S_ck_dump(pTHX_ OP *entersubop, GV *namegv, SV *cv)
+{
+    OP *aop, *prev, *first, *second = NULL;
+    BINOP *newop;
+    size_t arg = 0;
+
+    ck_entersub_args_proto(entersubop, namegv,
+			   newSVpvn_flags("$;$", 3, SVs_TEMP));
+
+    aop = cUNOPx(entersubop)->op_first;
+    if (!aop->op_sibling)
+	aop = cUNOPx(aop)->op_first;
+    prev = aop;
+    aop = aop->op_sibling;
+    while (PL_madskills && aop->op_type == OP_STUB) {
+	prev = aop;
+	aop = aop->op_sibling;
+    }
+    if (PL_madskills && aop->op_type == OP_NULL) {
+	first = ((UNOP*)aop)->op_first;
+	((UNOP*)aop)->op_first = NULL;
+	prev = aop;
+    }
+    else {
+	first = aop;
+	prev->op_sibling = first->op_sibling;
+    }
+    if (first->op_type == OP_RV2AV ||
+	first->op_type == OP_PADAV ||
+	first->op_type == OP_RV2HV ||
+	first->op_type == OP_PADHV
+    )
+	first->op_flags |= OPf_REF;
+    else
+	first->op_flags &= ~OPf_MOD;
+    aop = aop->op_sibling;
+    while (PL_madskills && aop->op_type == OP_STUB) {
+	prev = aop;
+	aop = aop->op_sibling;
+    }
+    /* aop now points to the second arg if there is one, the cvop otherwise
+     */
+    if (aop->op_sibling) {
+	prev->op_sibling = aop->op_sibling;
+	second = aop;
+	second->op_sibling = NULL;
+    }
+    first->op_sibling = second;
+
+    op_free(entersubop);
+
+    NewOp(1234, newop, 1, BINOP);
+    newop->op_type   = OP_CUSTOM;
+    newop->op_ppaddr = S_pp_dump;
+    newop->op_first  = first;
+    newop->op_last   = second;
+    newop->op_private= second ? 2 : 1;
+    newop->op_flags  = OPf_KIDS|OPf_WANT_SCALAR;
+
+    return (OP *)newop;
+}
+
+static XOP my_xop;
+
 MODULE = Devel::Peek		PACKAGE = Devel::Peek
 
 void
@@ -346,14 +435,18 @@ SV *	sv
 I32	lim
 PPCODE:
 {
-    SV *pv_lim_sv = perl_get_sv("Devel::Peek::pv_limit", 0);
-    const STRLEN pv_lim = pv_lim_sv ? SvIV(pv_lim_sv) : 0;
-    SV *dumpop = perl_get_sv("Devel::Peek::dump_ops", 0);
-    const U16 save_dumpindent = PL_dumpindent;
-    PL_dumpindent = 2;
-    do_sv_dump(0, Perl_debug_log, sv, 0, lim,
-	       (bool)(dumpop && SvTRUE(dumpop)), pv_lim);
-    PL_dumpindent = save_dumpindent;
+    S_do_dump(aTHX_ sv, lim);
+}
+
+BOOT:
+{
+    CV * const cv = get_cvn_flags("Devel::Peek::Dump", 17, 0);
+    cv_set_call_checker(cv, S_ck_dump, (SV *)cv);
+
+    XopENTRY_set(&my_xop, xop_name, "Dump");
+    XopENTRY_set(&my_xop, xop_desc, "Dump");
+    XopENTRY_set(&my_xop, xop_class, OA_BINOP);
+    Perl_custom_op_register(aTHX_ S_pp_dump, &my_xop);
 }
 
 void
diff --git a/ext/Devel-Peek/t/Peek.t b/ext/Devel-Peek/t/Peek.t
index e1761c71ff..785d3bd380 100644
--- a/ext/Devel-Peek/t/Peek.t
+++ b/ext/Devel-Peek/t/Peek.t
@@ -31,11 +31,24 @@ sub do_test {
     my $todo = $_[3];
     my $repeat_todo = $_[4];
     my $pattern = $_[2];
+    my $do_eval = $_[5];
     if (open(OUT,">peek$$")) {
 	open(STDERR, ">&OUT") or die "Can't dup OUT: $!";
-	Dump($_[1]);
-        print STDERR "*****\n";
-        Dump($_[1]); # second dump to compare with the first to make sure nothing changed.
+        if ($do_eval) {
+            my $sub = eval "sub { Dump $_[1] }";
+            $sub->();
+            print STDERR "*****\n";
+            # second dump to compare with the first to make sure nothing
+            # changed.
+            $sub->();
+        }
+        else {
+            Dump($_[1]);
+            print STDERR "*****\n";
+            # second dump to compare with the first to make sure nothing
+            # changed.
+            Dump($_[1]);
+        }
 	open(STDERR, ">&SAVERR") or die "Can't restore STDERR: $!";
 	close(OUT);
 	if (open(IN, "peek$$")) {
@@ -196,8 +209,8 @@ do_test('integer constant',
 do_test('undef',
         undef,
 'SV = NULL\\(0x0\\) at $ADDR
-  REFCNT = 1
-  FLAGS = \\(\\)');
+  REFCNT = \d+
+  FLAGS = \\(READONLY\\)');
 
 do_test('reference to scalar',
         \$a,
@@ -335,6 +348,8 @@ do_test('reference to named subroutine without prototype',
        \\d+\\. $ADDR<\\d+> \\(\\d+,\\d+\\) "\\$todo"
        \\d+\\. $ADDR<\\d+> \\(\\d+,\\d+\\) "\\$repeat_todo"
        \\d+\\. $ADDR<\\d+> \\(\\d+,\\d+\\) "\\$pattern"
+       \\d+\\. $ADDR<\\d+> \\(\\d+,\\d+\\) "\\$do_eval"
+      \\d+\\. $ADDR<\\d+> \\(\\d+,\\d+\\) "\\$sub"
       \\d+\\. $ADDR<\\d+> FAKE "\\$DEBUG"			# $] < 5.009
       \\d+\\. $ADDR<\\d+> FAKE "\\$DEBUG" flags=0x0 index=0	# $] >= 5.009
       \\d+\\. $ADDR<\\d+> \\(\\d+,\\d+\\) "\\$dump"
@@ -968,6 +983,59 @@ do_test('large hash',
     Elt .*
 ');
 
+# Dump with arrays, hashes, and operator return values
+@array = 1..3;
+do_test('Dump @array', '@array', <<'ARRAY', '', '', 1);
+SV = PVAV\($ADDR\) at $ADDR
+  REFCNT = 1
+  FLAGS = \(\)
+  ARRAY = $ADDR
+  FILL = 2
+  MAX = 3
+  ARYLEN = 0x0
+  FLAGS = \(REAL\)
+  Elt No. 0
+  SV = IV\($ADDR\) at $ADDR
+    REFCNT = 1
+    FLAGS = \(IOK,pIOK\)
+    IV = 1
+  Elt No. 1
+  SV = IV\($ADDR\) at $ADDR
+    REFCNT = 1
+    FLAGS = \(IOK,pIOK\)
+    IV = 2
+  Elt No. 2
+  SV = IV\($ADDR\) at $ADDR
+    REFCNT = 1
+    FLAGS = \(IOK,pIOK\)
+    IV = 3
+ARRAY
+%hash = 1..2;
+do_test('Dump %hash', '%hash', <<'HASH', '', '', 1);
+SV = PVHV\($ADDR\) at $ADDR
+  REFCNT = 1
+  FLAGS = \(SHAREKEYS\)
+  ARRAY = $ADDR  \(0:7, 1:1\)
+  hash quality = 100.0%
+  KEYS = 1
+  FILL = 1
+  MAX = 7
+  Elt "1" HASH = $ADDR
+  SV = IV\($ADDR\) at $ADDR
+    REFCNT = 1
+    FLAGS = \(IOK,pIOK\)
+    IV = 2
+HASH
+$_ = "hello";
+do_test('rvalue substr', 'substr $_, 1, 2', <<'SUBSTR', '', '', 1);
+SV = PV\($ADDR\) at $ADDR
+  REFCNT = 1
+  FLAGS = \(PADTMP,POK,pPOK\)
+  PV = $ADDR "el"\\0
+  CUR = 2
+  LEN = \d+
+SUBSTR
+
 SKIP: {
     skip "Not built with usemymalloc", 2
       unless $Config{usemymalloc} eq 'y';