summaryrefslogtreecommitdiff
path: root/ext
diff options
context:
space:
mode:
Diffstat (limited to 'ext')
-rw-r--r--ext/Devel/Peek/Peek.pm40
-rw-r--r--ext/Devel/Peek/Peek.xs15
2 files changed, 53 insertions, 2 deletions
diff --git a/ext/Devel/Peek/Peek.pm b/ext/Devel/Peek/Peek.pm
index 16471bd519..b2b0fc7122 100644
--- a/ext/Devel/Peek/Peek.pm
+++ b/ext/Devel/Peek/Peek.pm
@@ -4,14 +4,14 @@
package Devel::Peek;
# Underscore to allow older Perls to access older version from CPAN
-$VERSION = '1.00_02';
+$VERSION = '1.00_03';
require Exporter;
use XSLoader ();
@ISA = qw(Exporter);
@EXPORT = qw(Dump mstat DeadCode DumpArray DumpWithOP DumpProg
- fill_mstats mstats_fillhash mstats2hash);
+ fill_mstats mstats_fillhash mstats2hash runops_debug debug_flags);
@EXPORT_OK = qw(SvREFCNT SvREFCNT_inc SvREFCNT_dec CvGV);
%EXPORT_TAGS = ('ALL' => [@EXPORT, @EXPORT_OK]);
@@ -23,6 +23,26 @@ sub DumpWithOP ($;$) {
Dump($_[0],$depth);
}
+$D_flags = 'psltocPmfrxuLHXDSTR';
+
+sub debug_flags (;$) {
+ my $out = "";
+ for my $i (0 .. length($D_flags)-1) {
+ $out .= substr $D_flags, $i, 1 if $^D & (1<<$i);
+ }
+ my $arg = shift;
+ my $num = $arg;
+ if (defined $arg and $arg =~ /\D/) {
+ die "unknown flags in debug_flags()" if $arg =~ /[^-$D_flags]/;
+ my ($on,$off) = split /-/, "$arg-";
+ $num = $^D;
+ $num |= (1<<index($D_flags, $_)) for split //, $on;
+ $num &= ~(1<<index($D_flags, $_)) for split //, $off;
+ }
+ $^D = $num if defined $arg;
+ $out
+}
+
1;
__END__
@@ -68,6 +88,22 @@ The global variable $Devel::Peek::pv_limit can be set to limit the
number of character printed in various string values. Setting it to 0
means no limit.
+=head2 Runtime debugging
+
+C<CvGV($cv)> return one of the globs associated to a subroutine reference $cv.
+
+debug_flags() returns a string representation of C<$^D> (similar to
+what is allowed for B<-D> flag). When called with a numeric argument,
+sets $^D to the corresponding value. When called with an argument of
+the form C<"flags-flags">, set on/off bits of C<$^D> corresponding to
+letters before/after C<->. (The returned value is for C<$^D> before
+the modification.)
+
+runops_debug() returns true if the current I<opcode dispatcher> is the
+debugging one. When called with an argument, switches to debugging or
+non-debugging dispatcher depending on the argument (active for
+newly-entered subs/etc only). (The returned value is for the dispatcher before the modification.)
+
=head2 Memory footprint debugging
When perl is compiled with support for memory footprint debugging
diff --git a/ext/Devel/Peek/Peek.xs b/ext/Devel/Peek/Peek.xs
index a2a4186ab8..a1c297071a 100644
--- a/ext/Devel/Peek/Peek.xs
+++ b/ext/Devel/Peek/Peek.xs
@@ -3,6 +3,18 @@
#include "perl.h"
#include "XSUB.h"
+bool
+_runops_debug(int flag)
+{
+ dTHX;
+ bool d = PL_runops == MEMBER_TO_FPTR(Perl_runops_debug);
+
+ if (flag >= 0)
+ PL_runops
+ = MEMBER_TO_FPTR(flag ? Perl_runops_debug : Perl_runops_standard);
+ return d;
+}
+
SV *
DeadCode(pTHX)
{
@@ -400,3 +412,6 @@ MODULE = Devel::Peek PACKAGE = Devel::Peek PREFIX = _
SV *
_CvGV(cv)
SV *cv
+
+bool
+_runops_debug(int flag = -1)