line | code |
1 | package Debug::Client; |
2 | use strict; |
3 | use warnings; |
4 | use 5.006; |
5 | |
6 | our $VERSION = '0.12'; |
7 | |
8 | use IO::Socket; |
9 | use Carp (); |
10 | |
11 - 108 | | =head1 NAME
Debug::Client - client side code for perl debugger
=head1 SYNOPIS
use Debug::Client;
my $debugger = Debug::Client->new(host => $host, port => $port);
$debugger->listen;
Where $host is the hostname to be used by the script under test (SUT)
to acces the machine where Debug::Client runs. If they are on the same machine
this should be C<localhost>.
$port can be any port number where the Debug::Client could listen.
This is the point where the external SUT needs to be launched
by first setting
$ENV{PERLDB_OPTS} = "RemotePort=$host:$port"
then running
perl -d script
Once the script under test wa launched we can call the following:
my $out = $debugger->get;
$out = $debugger->step_in;
$out = $debugger->step_over;
my ($prompt, $module, $file, $row, $content) = $debugger->step_in;
my ($module, $file, $row, $content, $return_value) = $debugger->step_out;
my $value = $debugger->get_value('$x');
$debugger->run(); # run till end of breakpoint or watch
$debugger->run( 42 ); # run till line 42 (c in the debugger)
$debugger->run( 'foo' ); # run till beginning of sub
$debugger->execute_code( '$answer = 42' );
$debugger->execute_code( '@name = qw(foo bar)' );
my $value = $debugger->get_value('@name'); $value is the dumped data?
$debugger->execute_code( '%phone_book = (foo => 123, bar => 456)' );
my $value = $debugger->get_value('%phone_book'); $value is the dumped data?
$debugger->set_breakpoint( "file", 23 ); # set breakpoint on file, line
$debugger->get_stack_trace
Other planned methods:
$debugger->set_breakpoint( "file", 23, COND ); # set breakpoint on file, line, on condition
$debugger->set_breakpoint( "file", subname, [COND] )
$debugger->set_watch
$debugger->remove_watch
$debugger->remove_breakpoint
$debugger->watch_variable (to make it easy to display values of variables)
=head2 example
my $script = 'script_to_debug.pl';
my @args = ('param', 'param');
my $perl = $^X; # the perl might be a different perl
my $host = 'localhost';
my $port = 12345;
my $pid = fork();
die if not defined $pid;
if (not $pid) {
local $ENV{PERLDB_OPTS} = "RemotePort=$host:$port"
exec("$perl -d $script @args");
}
require Debug::Client;
my $debugger = Debug::Client->new(
host => $host,
port => $port,
);
$debugger->listen;
my $out = $debugger->get;
$out = $debugger->step_in;
# ...
=head1 DESCRIPTION
=cut |
109 | |
110 - 124 | | =head2 new
The constructor can get two parameters: host and port.
my $d = Debug::Client->new;
my $d = Debug::Client->new(host => 'remote.hots.com', port => 4242);
Immediately after the object creation one needs to call
$d->listen;
TODO: Is there any reason to separate the two?
=cut |
125 | |
126 | sub new { |
127 | my ( $class, %args ) = @_; |
128 | my $self = bless {}, $class; |
129 | |
130 | %args = ( |
131 | host => 'localhost', port => 12345, |
132 | %args |
133 | ); |
134 | |
135 | $self->{host} = $args{host}; |
136 | $self->{port} = $args{port}; |
137 | |
138 | return $self; |
139 | } |
140 | |
141 - 145 | | =head2 listen
See C<new>
=cut |
146 | |
147 | sub listen { |
148 | my ($self) = @_; |
149 | |
150 | # Open the socket the debugger will connect to. |
151 | my $sock = IO::Socket::INET->new( |
152 | LocalHost => $self->{host}, |
153 | LocalPort => $self->{port}, |
154 | Proto => 'tcp', |
155 | Listen => SOMAXCONN, |
156 | Reuse => 1 |
157 | ); |
158 | $sock or die "Could not connect to '$self->{host}' '$self->{port}' no socket :$!"; |
159 | _logger("listening on '$self->{host}:$self->{port}'"); |
160 | $self->{sock} = $sock; |
161 | |
162 | $self->{new_sock} = $self->{sock}->accept(); |
163 | |
164 | return; |
165 | } |
166 | |
167 - 173 | | =head2 buffer
Returns the content of the buffer since the last command
$debugger->buffer;
=cut |
174 | |
175 | sub buffer { |
176 | my ($self) = @_; |
177 | return $self->{buffer}; |
178 | } |
179 | |
180 - 182 | | =head2 quit
=cut |
183 | |
184 | sub quit { $_[0]->_send('q') } |
185 | |
186 - 188 | | =head2 show_line
=cut |
189 | |
190 | sub show_line { $_[0]->send_get('.') } |
191 | |
192 | |
193 - 195 | | =head2 step_in
=cut |
196 | |
197 | sub step_in { $_[0]->send_get('s') } |
198 | |
199 - 201 | | =head2 step_over
=cut |
202 | |
203 | sub step_over { $_[0]->send_get('n') } |
204 | |
205 - 220 | | =head2 step_out
my ($prompt, $module, $file, $row, $content, $return_value) = $debugger->step_out;
Where $prompt is just a number, probably useless
$return_value will be undef if the function was called in VOID context
It will hold a scalar value if called in SCALAR context
It will hold a reference to an array if called in LIST context.
TODO: check what happens when the return value is a reference to a complex data structure
or when some of the elements of the returned array are themselves references
=cut |
221 | |
222 | sub step_out { |
223 | my ($self) = @_; |
224 | |
225 | Carp::croak('Must call step_out in list context') if not wantarray; |
226 | |
227 | $self->_send('r'); |
228 | my $buf = $self->_get; |
229 | |
230 | # void context return from main::f |
231 | # scalar context return from main::f: 242 |
232 | # list context return from main::f: |
233 | # 0 22 |
234 | # 1 34 |
235 | # main::(t/eg/02-sub.pl:9): my $z = $x + $y; |
236 | |
237 | # list context return from main::g: |
238 | # 0 'baz' |
239 | # 1 'foo |
240 | # bar' |
241 | # 2 'moo' |
242 | # main::(t/eg/03-return.pl:10): $x++; |
243 | |
244 | $self->_prompt( \$buf ); |
245 | my @line = $self->_process_line( \$buf ); |
246 | my $ret; |
247 | my $context; |
248 | if ( $buf =~ /^(scalar|list) context return from (\S+):\s*(.*)/s ) { |
249 | $context = $1; |
250 | $ret = $3; |
251 | } |
252 | |
253 | #if ($context and $context eq 'list') { |
254 | # TODO can we parse this inteligently in the general case? |
255 | #} |
256 | return ( @line, $ret ); |
257 | } |
258 | |
259 | |
260 - 267 | | =head2 get_stack_trace
Sends the stack trace command C<T> to the remote debugger
and returns it as a string if called in scalar context.
Returns the prompt number and the stack trace string
when called in array context.
=cut |
268 | |
269 | sub get_stack_trace { |
270 | my ($self) = @_; |
271 | $self->_send('T'); |
272 | my $buf = $self->_get; |
273 | |
274 | $self->_prompt( \$buf ); |
275 | return $buf; |
276 | } |
277 | |
278 - 287 | | =head2 run
$d->run;
Will run till the next breakpoint or watch or the end of
the script. (Like pressing c in the debugger).
$d->run($param)
=cut |
288 | |
289 | sub run { |
290 | my ( $self, $param ) = @_; |
291 | if ( not defined $param ) { |
292 | $self->send_get('c'); |
293 | } else { |
294 | $self->send_get("c $param"); |
295 | } |
296 | } |
297 | |
298 | |
299 - 303 | | =head2 set_breakpoint
$d->set_breakpoint($file, $line, $condition);
=cut |
304 | |
305 | |
306 | sub set_breakpoint { |
307 | my ( $self, $file, $line, $cond ) = @_; |
308 | |
309 | $self->_send("f $file"); |
310 | my $b = $self->_get; |
311 | |
312 | # Already in t/eg/02-sub.pl. |
313 | |
314 | $self->_send("b $line"); |
315 | |
316 | # if it was successful no reply |
317 | # if it failed we saw two possible replies |
318 | my $buf = $self->_get; |
319 | my $prompt = $self->_prompt( \$buf ); |
320 | if ( $buf =~ /^Subroutine [\w:]+ not found\./ ) { |
321 | |
322 | # failed |
323 | return 0; |
324 | } elsif ( $buf =~ /^Line \d+ not breakable\./ ) { |
325 | |
326 | # faild to set on line number |
327 | return 0; |
328 | } elsif ( $buf =~ /\S/ ) { |
329 | return 0; |
330 | } |
331 | |
332 | return 1; |
333 | } |
334 | |
335 | # apparently no clear success/error report for this |
336 | sub remove_breakpoint { |
337 | my ( $self, $file, $line ) = @_; |
338 | |
339 | $self->_send("f $file"); |
340 | my $b = $self->_get; |
341 | |
342 | $self->_send("B $line"); |
343 | my $buf = $self->_get; |
344 | return 1; |
345 | } |
346 | |
347 - 363 | | =head2 list_break_watch_action
In scalar context returns the list of all the breakpoints
and watches as a text output. The data as (L) prints in the
command line debugger.
In list context it returns the promt number,
and a list of hashes. Each hash has
file =>
line =>
cond =>
to provide the filename, line number and the condition of the breakpoint.
In case of no condition the last one will be the number 1.
=cut |
364 | |
365 | sub list_break_watch_action { |
366 | my ($self) = @_; |
367 | |
368 | my $ret = $self->send_get('L'); |
369 | if ( not wantarray ) { |
370 | return $ret; |
371 | } |
372 | |
373 | # t/eg/04-fib.pl: |
374 | # 17: my $n = shift; |
375 | # break if (1) |
376 | my $buf = $self->buffer; |
377 | my $prompt = $self->_prompt( \$buf ); |
378 | |
379 | my @breakpoints; |
380 | my %bp; |
381 | my $PATH = qr{[\w./-]+}; |
382 | my $LINE = qr{\d+}; |
383 | my $CODE = qr{.*}s; |
384 | my $COND = qr{1}; ## TODO !!! |
385 | |
386 | while ($buf) { |
387 | if ( $buf =~ s{^($PATH):\s*($LINE):\s*($CODE)\s+break if \(($COND)\)s*}{} ) { |
388 | my %bp = ( |
389 | file => $1, |
390 | line => $2, |
391 | cond => $4, |
392 | ); |
393 | push @breakpoints, \%bp; |
394 | } else { |
395 | die "No breakpoint found in '$buf'"; |
396 | } |
397 | } |
398 | |
399 | return ( $prompt, \@breakpoints ); |
400 | } |
401 | |
402 | |
403 - 407 | | =head2 execute_code
$d->execute_code($some_code_to_execute);
=cut |
408 | |
409 | sub execute_code { |
410 | my ( $self, $code ) = @_; |
411 | |
412 | return if not defined $code; |
413 | |
414 | $self->_send($code); |
415 | my $buf = $self->_get; |
416 | $self->_prompt( \$buf ); |
417 | return $buf; |
418 | } |
419 | |
420 - 428 | | =head2 get_value
my $value = $d->get_value($x);
If $x is a scalar value, $value will contain that value.
If it is a reference to a SCALAR, ARRAY or HASH then $value should be the
value of that reference?
=cut |
429 | |
430 | # TODO if the given $x is a reference then something (either this module |
431 | # or its user) should actually call x $var |
432 | sub get_value { |
433 | my ( $self, $var ) = @_; |
434 | die "no parameter given\n" if not defined $var; |
435 | |
436 | if ( $var =~ /^\$/ ) { |
437 | $self->_send("p $var"); |
438 | my $buf = $self->_get; |
439 | $self->_prompt( \$buf ); |
440 | return $buf; |
441 | } elsif ( $var =~ /\@/ or $var =~ /\%/ ) { |
442 | $self->_send("x \\$var"); |
443 | my $buf = $self->_get; |
444 | $self->_prompt( \$buf ); |
445 | my $data_ref = _parse_dumper($buf); |
446 | return $data_ref; |
447 | } |
448 | die "Unknown parameter '$var'\n"; |
449 | } |
450 | |
451 | sub _parse_dumper { |
452 | my ($str) = @_; |
453 | return $str; |
454 | } |
455 | |
456 | # TODO shall we add a timeout and/or a number to count down the number |
457 | # sysread calls that return 0 before deciding it is really done |
458 | sub _get { |
459 | my ($self) = @_; |
460 | |
461 | #my $remote_host = gethostbyaddr($sock->sockaddr(), AF_INET) || 'remote'; |
462 | my $buf = ''; |
463 | while ( $buf !~ /DB<\d+>/ ) { |
464 | my $ret = $self->{new_sock}->sysread( $buf, 1024, length $buf ); |
465 | if ( not defined $ret ) { |
466 | die $!; # TODO better error handling? |
467 | } |
468 | _logger("---- ret '$ret'\n$buf\n---"); |
469 | if ( not $ret ) { |
470 | last; |
471 | } |
472 | } |
473 | _logger("_get done"); |
474 | |
475 | $self->{buffer} = $buf; |
476 | return $buf; |
477 | } |
478 | |
479 | # This is an internal method. |
480 | # It takes one argument which is a reference to a scalar that contains the |
481 | # the text sent by the debugger. |
482 | # Extracts and prompt that looks like this: DB<3> $ |
483 | # puts the number from the prompt in $self->{prompt} and also returns it. |
484 | # See 00-internal.t for test cases |
485 | sub _prompt { |
486 | my ( $self, $buf ) = @_; |
487 | |
488 | if ( not defined $buf or not ref $buf or ref $buf ne 'SCALAR' ) { |
489 | Carp::croak('_prompt should be called with a reference to a scalar'); |
490 | } |
491 | |
492 | my $prompt; |
493 | if ( $$buf =~ s/\s*DB<(\d+)>\s*$// ) { |
494 | $prompt = $1; |
495 | } |
496 | chomp($$buf); |
497 | |
498 | return $self->{prompt} = $prompt; |
499 | } |
500 | |
501 | # Internal method that receives a reference to a scalar |
502 | # containing the data printed by the debugger |
503 | # If the output indicates that the debugger terminated return '<TERMINATED>' |
504 | # Otherwise it returns ( $package, $file, $row, $content ); |
505 | # where |
506 | # $package is main:: or Some::Module:: (the current package) |
507 | # $file is the full or relative path to the current file |
508 | # $row is the current row number |
509 | # $content is the content of the current row |
510 | # see 00-internal.t for test cases |
511 | sub _process_line { |
512 | my ( $self, $buf ) = @_; |
513 | |
514 | if ( not defined $buf or not ref $buf or ref $buf ne 'SCALAR' ) { |
515 | Carp::croak('_process_line should be called with a reference to a scalar'); |
516 | } |
517 | |
518 | if ( $$buf =~ /Debugged program terminated/ ) { |
519 | return '<TERMINATED>'; |
520 | } |
521 | |
522 | my @parts = split /\n/, $$buf; |
523 | my $line = pop @parts; |
524 | |
525 | # try to debug some test reports |
526 | # http://www.nntp.perl.org/group/perl.cpan.testers/2009/12/msg6542852.html |
527 | if ( not defined $line ) { |
528 | Carp::croak("Debug::Client: Line is undef. Buffer is '$$buf'"); |
529 | } |
530 | _logger("Line: '$line'"); |
531 | my $cont; |
532 | if ( $line =~ /^\d+: \s* (.*)$/x ) { |
533 | $cont = $1; |
534 | $line = pop @parts; |
535 | _logger("Line2: '$line'"); |
536 | } |
537 | |
538 | $$buf = join "\n", @parts; |
539 | my ( $module, $file, $row, $content ); |
540 | |
541 | # the last line before |
542 | # main::(t/eg/01-add.pl:8): my $z = $x + $y; |
543 | if ($line =~ /^([\w:]*) # module |
544 | \( ([^\)]*):(\d+) \) # (file:row) |
545 | :\t? # : |
546 | (.*) # content |
547 | /mx |
548 | ) |
549 | { |
550 | ( $module, $file, $row, $content ) = ( $1, $2, $3, $4 ); |
551 | } |
552 | if ($cont) { |
553 | $content = $cont; |
554 | } |
555 | $self->{filename} = $file; |
556 | $self->{row} = $row; |
557 | return ( $module, $file, $row, $content ); |
558 | } |
559 | |
560 - 573 | | =head get
Actually I think this is an internal method....
In SCALAR context will return all the buffer collected since the last command.
In LIST context will return ($prompt, $module, $file, $row, $content)
Where $prompt is the what the standard debugger uses for prompt. Probably not too
interesting.
$file and $row describe the location of the next instructions.
$content is the actual line - this is probably not too interesting as it is
in the editor. $module is just the name of the module in which the current execution is.
=cut |
574 | |
575 | sub get { |
576 | my ($self) = @_; |
577 | |
578 | my $buf = $self->_get; |
579 | |
580 | if (wantarray) { |
581 | $self->_prompt( \$buf ); |
582 | my ( $module, $file, $row, $content ) = $self->_process_line( \$buf ); |
583 | return ( $module, $file, $row, $content ); |
584 | } else { |
585 | return $buf; |
586 | } |
587 | } |
588 | |
589 | sub _send { |
590 | my ( $self, $input ) = @_; |
591 | |
592 | #print "Sending '$input'\n"; |
593 | print { $self->{new_sock} } "$input\n"; |
594 | } |
595 | |
596 | sub send_get { |
597 | my ( $self, $input ) = @_; |
598 | $self->_send($input); |
599 | |
600 | return $self->get; |
601 | } |
602 | |
603 | sub filename { return $_[0]->{filename} } |
604 | sub row { return $_[0]->{row} } |
605 | |
606 | sub _logger { |
607 | print "LOG: $_[0]\n" if $ENV{DEBUG_LOGGER}; |
608 | } |
609 | |
610 | |
611 - 635 | | =head1 See Also
L<GRID::Machine::remotedebugtut>
=head1 COPYRIGHT
Copyright 2008-2011 Gabor Szabo. L<http://szabgab.com/>
=head1 LICENSE
This program is free software; you can redistribute it and/or
modify it under the same terms as Perl 5 itself.
=head1 WARRANTY
There is no warranty whatsoever.
If you lose data or your hair because of this program,
that's your problem.
=head1 CREDITS and THANKS
Originally started out from the remoteport.pl script from
Pro Perl Debugging written by Richard Foley.
=cut |
636 | |
637 | 1; |