diff options
Diffstat (limited to 'ext')
| -rw-r--r-- | ext/Devel-Peek/Peek.xs | 109 | ||||
| -rw-r--r-- | ext/Devel-Peek/t/Peek.t | 78 |
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'; |