Front page | perl.perl5.porters |
Postings from August 2011
[PATCH] Add enable/disable commands for breakpoints in perl -d
Thread Next
From:
Shlomi Fish
Date:
August 30, 2011 11:48
Subject:
[PATCH] Add enable/disable commands for breakpoints in perl -d
Message ID:
20110830214155.536c9f78@lap.shlomifish.org
This patch adds enable/disable commands for breakpoints in "perl -d" similar to
the gdb ones. For the motivation see:
http://www.xray.mpe.mpg.de/mailing-lists/perl5-porters/2011-02/msg00348.html
It can also be found as a series of commits here:
https://github.com/shlomif/perl/tree/debugger-enable-disable-breakpoints
(But some of these commits break the MANIFEST test.).
Comments are welcome.
Regards,
Shlomi Fish
diff --git a/MANIFEST b/MANIFEST
index f33a68b..a2dbf2a 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -4031,6 +4031,10 @@ lib/overload.t See if operator
overloading works lib/perl5db.pl Perl debugging routines
lib/perl5db.t Tests for the Perl debugger
lib/perl5db/t/breakpoint-bug Test script used by perl5db.t
+lib/perl5db/t/disable-breakpoints-1 Test script used by perl5db.t
+lib/perl5db/t/disable-breakpoints-2 Test script used by perl5db.t
+lib/perl5db/t/disable-breakpoints-3 Test script used by perl5db.t
+lib/perl5db/t/EnableModule.pm Tests for the Perl debugger
lib/perl5db/t/eval-line-bug Tests for the Perl debugger
lib/perl5db/t/filename-line-breakpoint Tests for the Perl
debugger lib/perl5db/t/lvalue-bug Tests for the Perl debugger
diff --git a/lib/perl5db.pl b/lib/perl5db.pl
index 89118f6..3d17d8f 100644
--- a/lib/perl5db.pl
+++ b/lib/perl5db.pl
@@ -1929,6 +1929,7 @@ sub DB {
# if we have something here, see if we should break.
if ( $dbline{$line}
+ && _is_breakpoint_enabled($filename, $line)
&& ( ( $stop, $action ) = split( /\0/, $dbline{$line} ) ) )
{
@@ -3275,6 +3276,38 @@ pick it up.
next CMD;
};
+ $cmd =~ /^(enable|disable)\s+(\S+)\s*$/ && do {
+ my ($cmd, $position) = ($1, $2);
+
+ my ($fn, $line_num);
+ if ($position =~ m{\A\d+\z})
+ {
+ $fn = $filename;
+ $line_num = $position;
+ }
+ elsif ($position =~ m{\A(.*):(\d+)\z})
+ {
+ ($fn, $line_num) = ($1, $2);
+ }
+ else
+ {
+ &warn("Wrong spec for enable/disable argument.\n");
+ }
+
+ if (defined($fn)) {
+ if (_has_breakpoint_data_ref($fn, $line_num)) {
+ _set_breakpoint_enabled_status($fn, $line_num,
+ ($cmd eq 'enable' ? 1 : '')
+ );
+ }
+ else {
+ &warn("No breakpoint set at ${fn}:${line_num}\n");
+ }
+ }
+
+ next CMD;
+ };
+
=head4 C<save> - send current history to a file
Takes the complete history, (not the shrunken version you see with C<H>),
@@ -3905,6 +3938,51 @@ my %set = ( #
},
);
+my %breakpoints_data;
+
+sub _has_breakpoint_data_ref {
+ my ($filename, $line) = @_;
+
+ return (
+ exists( $breakpoints_data{$filename} )
+ and
+ exists( $breakpoints_data{$filename}{$line} )
+ );
+}
+
+sub _get_breakpoint_data_ref {
+ my ($filename, $line) = @_;
+
+ return ($breakpoints_data{$filename}{$line} ||= +{});
+}
+
+sub _delete_breakpoint_data_ref {
+ my ($filename, $line) = @_;
+
+ delete($breakpoints_data{$filename}{$line});
+ if (! scalar(keys( %{$breakpoints_data{$filename}} )) ) {
+ delete($breakpoints_data{$filename});
+ }
+
+ return;
+}
+
+sub _set_breakpoint_enabled_status {
+ my ($filename, $line, $status) = @_;
+
+ _get_breakpoint_data_ref($filename, $line)->{'enabled'} =
+ ($status ? 1 : '')
+ ;
+
+ return;
+}
+
+sub _is_breakpoint_enabled {
+ my ($filename, $line) = @_;
+
+ return _get_breakpoint_data_ref($filename, $line)->{'enabled'};
+}
+
=head2 C<cmd_wrapper()> (API)
C<cmd_wrapper()> allows the debugger to switch command sets
@@ -4400,6 +4478,8 @@ sub break_on_line {
# Nothing here - just add the condition.
$dbline{$i} = $cond;
+
+ _set_breakpoint_enabled_status($filename, $i, 1);
}
} ## end sub break_on_line
@@ -4644,6 +4724,8 @@ are no magical debugger structures associated with them.
sub delete_breakpoint {
my $i = shift;
+ my $fn = $filename;
+
# If we got a line, delete just that one.
if ( defined($i) ) {
@@ -4654,7 +4736,10 @@ sub delete_breakpoint {
$dbline{$i} =~ s/^[^\0]*//;
# Remove the entry entirely if there's no action left.
- delete $dbline{$i} if $dbline{$i} eq '';
+ if ($dbline{$i} eq '') {
+ delete $dbline{$i};
+ _delete_breakpoint_data_ref($fn, $i);
+ }
}
# No line; delete them all.
@@ -4683,6 +4768,7 @@ sub delete_breakpoint {
# Remove the entry altogether if no action is there.
delete $dbline{$i};
+ _delete_breakpoint_data_ref($file, $i);
}
} ## end if (defined $dbline{$i...
} ## end for ($i = 1 ; $i <= $max...
diff --git a/lib/perl5db.t b/lib/perl5db.t
index e275356..a27aaaa 100644
--- a/lib/perl5db.t
+++ b/lib/perl5db.t
@@ -28,7 +28,7 @@ BEGIN {
}
}
-plan(11);
+plan(14);
my $rc_filename = '.perldb';
@@ -245,10 +245,91 @@ EOF
"Can set breakpoint in a line.");
}
+# Testing that we can disable a breakpoint at a numeric line.
+{
+ rc(<<'EOF');
+&parse_options("NonStop=0 TTY=db.out LineInfo=db.out");
+
+sub afterinit {
+ push (@DB::typeahead,
+ 'b 7',
+ 'b 11',
+ 'disable 7',
+ 'c',
+ q/print "X={$x}\n";/,
+ 'c',
+ 'q',
+ );
+
+}
+EOF
+
+ my $output = runperl(switches => [ '-d', ], stderr => 1, progfile =>
'../lib/perl5db/t/disable-breakpoints-1'); +
+ like($output, qr/
+ X=\{SecondVal\}
+ /msx,
+ "Can set breakpoint in a line.");
+}
+
+# Testing that we can re-enable a breakpoint at a numeric line.
+{
+ rc(<<'EOF');
+&parse_options("NonStop=0 TTY=db.out LineInfo=db.out");
+
+sub afterinit {
+ push (@DB::typeahead,
+ 'b 8',
+ 'b 24',
+ 'disable 24',
+ 'c',
+ 'enable 24',
+ 'c',
+ q/print "X={$x}\n";/,
+ 'c',
+ 'q',
+ );
+
+}
+EOF
+ my $output = runperl(switches => [ '-d', ], stderr => 1, progfile =>
'../lib/perl5db/t/disable-breakpoints-2');
+ like($output, qr/
+ X=\{SecondValOneHundred\}
+ /msx,
+ "Can set breakpoint in a line.");
+}
# clean up.
+# Disable and enable for breakpoints on outer files.
+{
+ rc(<<'EOF');
+&parse_options("NonStop=0 TTY=db.out LineInfo=db.out");
+
+sub afterinit {
+ push (@DB::typeahead,
+ 'b 10',
+ 'b ../lib/perl5db/t/EnableModule.pm:14',
+ 'disable ../lib/perl5db/t/EnableModule.pm:14',
+ 'c',
+ 'enable ../lib/perl5db/t/EnableModule.pm:14',
+ 'c',
+ q/print "X={$x}\n";/,
+ 'c',
+ 'q',
+ );
+
+}
+EOF
+
+ my $output = runperl(switches => [ '-d', '-I', '../lib/perl5db/t', ],
stderr => 1, progfile => '../lib/perl5db/t/disable-breakpoints-3'); +
+ like($output, qr/
+ X=\{SecondValTwoHundred\}
+ /msx,
+ "Can set breakpoint in a line.");
+}
END {
1 while unlink ($rc_filename, $out_fn);
}
diff --git a/lib/perl5db/t/EnableModule.pm b/lib/perl5db/t/EnableModule.pm
new file mode 100644
index 0000000..910a6db
--- /dev/null
+++ b/lib/perl5db/t/EnableModule.pm
@@ -0,0 +1,18 @@
+package EnableModule;
+
+use strict;
+use warnings;
+
+sub set_x
+{
+ my $x_ref = shift;
+
+ ${$x_ref} .= "TwoHundred";
+
+ my $x = ${$x_ref};
+
+ my $t = $x;
+ $t .= "Foo";
+}
+
+1;
diff --git a/lib/perl5db/t/disable-breakpoints-1
b/lib/perl5db/t/disable-breakpoints-1 new file mode 100644
index 0000000..10877d6
--- /dev/null
+++ b/lib/perl5db/t/disable-breakpoints-1
@@ -0,0 +1,19 @@
+#!/usr/bin/perl
+my $x = "One";
+my $dummy = 0;
+
+$x = "FirstVal";
+
+$dummy++;
+
+$x = "SecondVal";
+
+$dummy++;
+
+$x = "ThirdVal";
+
+$dummy++;
+
+$x = "FourthVal";
+
+$dummy++;
diff --git a/lib/perl5db/t/disable-breakpoints-2
b/lib/perl5db/t/disable-breakpoints-2 new file mode 100644
index 0000000..a3ab166
--- /dev/null
+++ b/lib/perl5db/t/disable-breakpoints-2
@@ -0,0 +1,26 @@
+#!/usr/bin/perl
+my $x = "One";
+
+$x = "FirstVal";
+
+set_x();
+
+$x = "SecondVal";
+
+set_x();
+
+$x = "ThirdVal";
+
+set_x();
+
+$x = "FourthVal";
+
+set_x();
+
+sub set_x
+{
+ $x .= "OneHundred";
+
+ my $t = $x;
+ $t .= "Foo";
+}
diff --git a/lib/perl5db/t/disable-breakpoints-3
b/lib/perl5db/t/disable-breakpoints-3 new file mode 100644
index 0000000..990abb1
--- /dev/null
+++ b/lib/perl5db/t/disable-breakpoints-3
@@ -0,0 +1,21 @@
+#!/usr/bin/perl
+
+use EnableModule;
+my $x = "One";
+
+$x = "FirstVal";
+
+EnableModule::set_x(\$x);
+
+$x = "SecondVal";
+
+EnableModule::set_x(\$x);
+
+$x = "ThirdVal";
+
+EnableModule::set_x(\$x);
+
+$x = "FourthVal";
+
+EnableModule::set_x(\$x);
+
diff --git a/pod/perldebug.pod b/pod/perldebug.pod
index 73e4f80..89334eb 100644
--- a/pod/perldebug.pod
+++ b/pod/perldebug.pod
@@ -352,6 +352,42 @@ X<debugger command, B>
Delete all installed breakpoints.
+=item disable [file]:[line]
+X<breakpoint>
+X<debugger command, disable>
+X<disable>
+
+Disable the breakpoint so it won't stop the execution of the program.
+Breakpoints are enabled by default and can be re-enabled using the C<enable>
+command.
+
+=item disable [line]
+X<breakpoint>
+X<debugger command, disable>
+X<disable>
+
+Disable the breakpoint so it won't stop the execution of the program.
+Breakpoints are enabled by default and can be re-enabled using the C<enable>
+command.
+
+This is done for a breakpoint in the current file.
+
+=item enable [file]:[line]
+X<breakpoint>
+X<debugger command, disable>
+X<disable>
+
+Enable the breakpoint so it will stop the execution of the program.
+
+=item enable [line]
+X<breakpoint>
+X<debugger command, disable>
+X<disable>
+
+Enable the breakpoint so it will stop the execution of the program.
+
+This is done for a breakpoint in the current file.
+
=item a [line] command
X<debugger command, a>
--
-----------------------------------------------------------------
Shlomi Fish http://www.shlomifish.org/
"Star Trek: We, the Living Dead" - http://shlom.in/st-wtld
<rjbs> sub id { my $self = shift; $json_parser_for{ $self }
->decode($json_for{ $self })->{id} } # Inside‐out JSON‐notated objects
Please reply to list if it's a mailing list post - http://shlom.in/reply .
Thread Next
-
[PATCH] Add enable/disable commands for breakpoints in perl -d
by Shlomi Fish