File Coverage

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

linecode
1package Debug::Client;
2use strict;
3use warnings;
4use 5.006;
5
6our $VERSION = '0.12';
7
8use IO::Socket;
9use 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
126sub 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
147sub 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
175sub buffer {
176        my ($self) = @_;
177        return $self->{buffer};
178}
179
180 - 182
=head2 quit

=cut
183
184sub quit { $_[0]->_send('q') }
185
186 - 188
=head2 show_line

=cut
189
190sub show_line { $_[0]->send_get('.') }
191
192
193 - 195
=head2 step_in

=cut
196
197sub step_in { $_[0]->send_get('s') }
198
199 - 201
=head2 step_over

=cut
202
203sub 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
222sub 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
269sub 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
289sub 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
306sub 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
336sub 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
365sub 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
409sub 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
432sub 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
451sub _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
458sub _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
485sub _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
511sub _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
575sub 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
589sub _send {
590        my ( $self, $input ) = @_;
591
592        #print "Sending '$input'\n";
593        print { $self->{new_sock} } "$input\n";
594}
595
596sub send_get {
597        my ( $self, $input ) = @_;
598        $self->_send($input);
599
600        return $self->get;
601}
602
603sub filename { return $_[0]->{filename} }
604sub row { return $_[0]->{row} }
605
606sub _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
6371;