File Coverage

blib/lib/Protocol/PerlDebugCLI.pm

Criterion	Covered	Total	%
statement	60	117	51.2
branch	11	32	34.3
condition	6	12	50.0
subroutine	14	27	51.8
pod	21	21	100.0
total	112	209	53.5

package Protocol::PerlDebugCLI;
# ABSTRACT: Interact with the Perl debugging interface using events
use strict;
use warnings;
use parent qw(Mixin::Event::Dispatch);
use Protocol::PerlDebugCLI::Request;

our $VERSION = '0.002';

=head1 NAME

Protocol::PerlDebugCLI - generate and process events for interacting with the Perl debug interface

=head1 VERSION

version 0.002

=head1 SYNOPSIS

 use Protocol::PerlDebugCLI;
 my $deb = Protocol::PerlDebugCLI->new;

 # Attach handlers for the events that we're interested in,
 # anything else will be quietly ignored
 $deb->add_handler_for_event(
   breakpoint => sub {
     warn "Breakpoint reached\n";
   },
 );

 # Set a breakpoint and continue execution
 $deb->request_breakpoint(
   file => 'script.pl',
   line => 17,
 );
 $deb->request_continue;

=head1 DESCRIPTION

This is an abstract implementation for interacting with the perl debugger.
It parses the debugger output (provided via the L method) and
and generates events, similar in concept to SAX.

It also provides abstract methods for generating commands to drive the
debugger; by hooking the C event a companion class or subclass
can drive the debugger without knowing the details of the protocol.

This class is not intended to be used directly - it deals with the abstract
protocol and requires additional code to deal with the transport layer
(this could be through sockets, via the RemotePort= PERLDBOPTS flag, or on
STDIN/STDOUT/TTY for a forked C process).

See L for an implementation of a transport
layer using RemotePort, and L for a L-based
terminal debugging application.

Other similar classes for interacting with the debugger are listed in the
L section.

=head1 METHODS

=cut

=head2 new

Instantiate a new object.

=cut

sub new {
	my $class = shift;
	my $self = bless { }, $class;

# Start with no queued requests, and until we get a prompt we're not ready to send requests yet
	$self->{queued_requests} = [];
	$self->{ready_for_request} = 0;

# Auto-send next request on prompt
	$self->add_handler_for_event(
		prompt => sub {
			my ($self, $depth) = @_;
			$self->send_next_request if $self->have_queued_requests;
			$self;
		}
	);
	return $self;
}

=head2 send_next_request

Attempt to send the next queued request to the debugger.

Expects the caller to have checked whether there are any requests pending,
and will raise an exception if this is not the case.

=cut

sub send_next_request {
	my $self = shift;
	die "No requests queued" unless my $req = shift @{$self->{queued_requests}};

	$self->write($req->command . "\n");
	return $self;
}

=head2 have_queued_requests

Returns true if there are queued requests.

=cut

sub have_queued_requests {
	my $self = shift;
	return @{$self->{queued_requests}} ? 1 : 0
}

=head2 current_state

Accessor for the current state.

Will raise an exception if attempting to set the state to the same value as it had previously.

=cut

sub current_state {
	my $self = shift;
	if(@_) {
		my $state = shift;
		die "Attempting to change state to the previous value: $state" if $state eq $self->{state};
		$self->{state} = shift;
		$self->invoke_event(state_changed => $self->{state});
		return $self;
	}
	return $self->{state};
}

=head2 parse_variable_dump_line

Parse variable dump output, typically from v or x commands.

=cut

sub parse_variable_dump_line {
	my $self = shift;
	my $line = shift;
	# FIXME Only handles simple scalar values at the moment
	if($line =~ s/^(\$|\%|\*|\@)(\w+)\s*=\s*//) {
		my $type = {
			'$'	=> 'scalar',
			'@'	=> 'array',
			'%'	=> 'hash',
			'*'	=> 'glob',
		}->{$1} || 'unknown';
		$self->invoke_event(have_variable =>
			type	=> $type,
			name	=> $2,
			data	=> $line
		);
	}
	return $self;
}

=head2 parse_code_context_line

Parse code context, which consists of the current active line and a few surrounding
lines.

=cut

sub parse_code_context_line {
	my $self = shift;
	my $line = shift;

	if($line =~ s/^(\d+)((?:==>)|(?::))?//) {
		my $line_number = $1;
		my $method = {
			'==>'	=> 'execution_line',
			':'	=> 'breakable',
			'none'	=> 'filler'
		}->{$2 || 'none'};
		$self->invoke_event(code_context =>
			method => $method,
			line => $line_number
		);
	}
	return $self;
}

=head2 parse_at_breakpoint

At a breakpoint we start with the spec, then get line(s) of code

=cut

sub parse_at_breakpoint {
	my $self = shift;
	my $line = shift;

	# Current file position
	if($line =~ s/^([\w:]+)\(([^:]+):(\d+)\)://) {
		my ($func, $file, $line) = ($1, $2, $3);
		$self->invoke_event(current_position =>
			function	=> $func,
			file		=> $file,
			line		=> $line
		);
	} elsif($line =~ s/^(\d+)((?:==>)|(?::))?//) {
		# Current file position
		my $line_number = $1;
		my $type = {
			'==>'	=> 'execution_line',
			':'	=> 'breakable',
			'none'	=> 'filler'
		}->{$2 || 'none'};
		$self->invoke_event(surrounding_code =>
			type => $type,
			line => $line_number,
			text => $line
		);
	} else {
		die "Unknown data: [$line]";
	}
	return $self;
}

=head2 on_read

Should be called by the transport layer when data is available for parsing.

Expects the following parameters:

=over 4

=item * $buffref - a scalar reference to the current read buffer. Any parseable
data will be extract from this buffer, modifying in-place. If there is insufficient
data to parse a full line then there may be some data left in this buffer on return,
and the transport layer should call us again after reading more data (and not before).

=item * $eof - a flag indicating that no further data is forthcoming. When this is set
we attempt to parse any trailing data and then go through any required cleanup before
returning.

=back

=cut

sub on_read {
	my ($self, $buffref, $eof) = @_;
	$self->{ready_for_request} = 0;

# First, parse any full lines we may have already
	while($$buffref =~ s/^(.*?)\n//) {
		my $line = $1;
		next unless $line =~ /\w/;
		if($line =~ /^Use /) {
			$self->invoke_event(execution_complete =>);
#		} elsif(@parser) {
#			$parser[0]->($line);
		} elsif($line =~ /^Loading DB routines/ || $line =~ /^Editor support/ || $line =~ /^Enter h/) {

			$self->invoke_event(unparsed_data => $line);
		} else {
			$self->parse_at_breakpoint($line);
		}
	}

# Check for prompt
	if($$buffref =~ s/^  DB<(\d+)> //) {
		$self->{ready_for_request} = 1;
		$self->invoke_event(prompt => $1);
	}
	return $self;
}

=head2 is_ready_for_request

Returns true if we're ready to send the next request (i.e. we're at a prompt).

=cut

sub is_ready_for_request {shift->{ready_for_request} }

=head2 request_stack_trace

Request a full stack trace.

=cut

sub request_stack_trace {
	my $self = shift;
	$self->queue_command(
		command	=> 'T',
	);

	return $self;
}

=head2 request_vars_in_scope

Request a dump of all vars in the current scope.

=cut

sub request_vars_in_scope {
	my $self = shift;
	$self->queue_command(
		command	=> 'y',
		on_start => sub {
			$self->{scope_vars} = [];
		},
		parser => 'parse_var_info',
	);
	return $self;
}

=head2 request_current_line

Request information about the current line (i.e. next line to be executed).

=cut

sub request_current_line {
	my $self = shift;
	$self->queue_command(
		command	=> 'y',
	);
	return $self;
}

=head2 request_step_into

Step into the current line.

=cut

sub request_step_into {
	my $self = shift;
	$self->queue_command(
		command	=> 's',
	);
	return $self;
}

=head2 request_step_over

Step over the current line.

=cut

sub request_step_over {
	my $self = shift;
	$self->queue_command(
		command	=> 'n',
	);
	return $self;
}

=head2 request_continue

Continue execution.

=cut

sub request_continue {
	my $self = shift;
	$self->queue_command(
		command	=> 'c',
	);
	return $self;
}

=head2 request_breakpoint

Set a breakpoint on the requested line.

=cut

sub request_breakpoint {
	my $self = shift;
	my %args = @_;
	$self->queue_command(
		command	=> 'b' . (exists $args{line} ? ' ' . $args{line} : ''),
	);
	return $self;
}

=head2 request_clear_breakpoint

Clear the given breakpoint.

Expects the following named parameters:

=over 4

=item * line - (optional) line number to clear breakpoints from

=back

If no line is provided, will clear all existing breakpoints.

=cut

sub request_clear_breakpoint {
	my $self = shift;
	my %args = @_;
	$self->queue_command(
		command	=> 'B ' . (exists $args{line} ? $args{line} : '*'),
	);
	return $self;
}

=head2 request_restart

Restart the current program.

=cut

sub request_restart {
	my $self = shift;
	$self->queue_command(
		command	=> 'R',
	);
	return $self;
}

=head2 request_watch

Request a watch on the given variable.

=cut

sub request_watch {
	my $self = shift;
	my %args = @_;
	$self->queue_command(
		command	=> 'w ' . $args{variable},
	);
	return $self;
}

=head2 queue_command

Queue the given command.

=cut

sub queue_command {
	my $self = shift;
	my $req = Protocol::PerlDebugCLI::Request->new(@_);
	push @{$self->{queued_requests}}, $req;
	$self->send_next_request if $self->is_ready_for_request;
	return $self;
}

=head2 write

Invokes a C event, requesting the given data be written to the
underlying transport.

=cut

sub write {
	my $self = shift;
	$self->invoke_event(write => shift);
	return $self;
}

1;

__END__