File Coverage

lib/Devel/ebug.pm

Criterion	Covered	Total	%
statement	77	78	98.7
branch	6	10	60.0
condition	1	3	33.3
subroutine	15	15	100.0
pod	1	3	33.3
total	100	109	91.7

package Devel::ebug;

use strict;
use warnings;
use Carp;
use Class::Accessor::Chained::Fast;
use Devel::StackTrace 2.00;
use IO::Socket::INET;
use Proc::Background;
use String::Koremutake;
use YAML;
use Module::Pluggable require => 1;

use base qw(Class::Accessor::Chained::Fast);

# ABSTRACT: A simple, extensible Perl debugger
our $VERSION = '0.64'; # VERSION

__PACKAGE__->mk_accessors(qw(
    backend
    port
    program socket proc
    package filename line codeline subroutine finished));

# let's run the code under our debugger and connect to the server it
# starts up
sub load {
  my $self = shift;
  my $program = $self->program;

  # import all the plugins into our namespace
  eval { $_->import } for $self->plugins;

  my $k = String::Koremutake->new;
  my $rand = int(rand(100_000));
  my $secret = $k->integer_to_koremutake($rand);
  my $port   = 3141 + ($rand % 1024);

  $ENV{SECRET} = $secret;
  my $backend = $self->backend || "$^X -d:ebug::Backend";
  my $command = "$backend $program";
  my $proc = Proc::Background->new(
    {'die_upon_destroy' => 1},
    $command
  );
  croak(qq{Devel::ebug: Failed to start up "$program" in load()}) unless $proc->alive;
  $self->proc($proc);
  $ENV{SECRET} = "";

  $self->attach($port, $secret);
}

sub attach {
    my ($self, $port, $key) = @_;

    # import all the plugins into our namespace
    eval { $_->import } for $self->plugins;

    # try and connect to the server
    my $socket;
    foreach ( 1 .. 10 ) {
        $socket = IO::Socket::INET->new(
            PeerAddr   => "localhost",
            PeerPort   => $port,
            Proto      => 'tcp',
            ReuseAddr => 1,
        );
        last if $socket;
        sleep 1;
    }
    die "Could not connect: $!" unless $socket;
    $self->socket($socket);

    my $response = $self->talk(
        {   command => "ping",
            version => $Devel::ebug::VERSION,
            secret  => $key,
        }
    );
    my $version = $response->{version};
    die "Client version $version != our version $Devel::ebug::VERSION"
        unless do { no warnings 'uninitialized'; $version eq $Devel::ebug::VERSION };

    $self->basic;    # get basic information for the first line
}

#
# FIXME : this would mean that plugin writers don't need to Export stuff
#
#sub load_plugins {
#    my $self = shift;
#    my $obj = Devel::Symdump->new($self->plugins);
#
#    for ($obj->functions) {
#        my $name = (split /::/)[-1];
#        next if substr($name,0,1) eq '_';
#        *basic = \&$_;
#    }
#
#}



# at the moment, we talk hex-encoded YAML serialisation
# don't worry about this too much
sub talk {
  my($self, $req) = @_;
  my $socket = $self->socket;

  my $data = unpack("h*", Dump($req));
  $socket->print($data . "\n");
  $data = <$socket>;
  if ($data) {
    my $res = do {
      $YAML::LoadBlessed = 1;
      Load(pack("h*", $data));
    };
    return $res;
  } else {
    return undef;
  }
}

1;

__END__