File Coverage: blib/lib/Debug/Client.pm

# File Coverage

File: | blib/lib/Debug/Client.pm
Coverage: | 0.0%

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;