| 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; |