view release on metacpan or  search on metacpan

bin/debugServer.pl  view on Meta::CPAN

#!/usr/bin/env perl

use strict;
use warnings;
use ZeroMQ qw/:all/;
use Time::HiRes qw(usleep nanosleep);
use Storable;
use Data::Dumper;

use Storable;
use Devel::Debug::Server;
use JSON;
use File::Spec;

# PODNAME: debugServer.pl

# ABSTRACT: The server to centralize debugging informations


my $cxt = ZeroMQ::Context->new;
my $responder = $cxt->socket(ZeroMQ::Constants::ZMQ_REP);
$responder->bind("tcp://127.0.0.1:5000");

my %processesInfos = ();

#commandes to send to process to debug (undef = nothing to do)
#each command is as below
#{command   => 'COMMAND_CODE',
#  arg1     => 'first argument if needed',
#  arg2     => 'second argument if needed',
#  arg3     => 'third argument if needed'
#  }
my %commands = ();

#a hash containing source files
my %files = ();

my $breakPointVersion = 0;
my $breakPoints = {}; #all the requested breakpoints
my $effectiveBreakpoints = {}; #all the breakpoints effectively set, with their real line number
my $lastBreakPointsUpdate = 0; #the last breakpoint list version that was propagate

#=comment  updateProcessInfo
#
#    Update informations of the process into the process table
#
#     my $programInfo = { 
#        pid          
#        name         
#        line         
#        subroutine   
#        package      
#        filename     
#        finished    
#        stackTrace   
#        variables    
#        result       
#
#    };
#=cut
sub updateProcessInfo {
    my ($infos) = @_;

    my $pid = $infos->{pid};
    $processesInfos{$pid} = $infos;

    #initialize other hashes if necessary
    if (!exists $commands{$pid}){
        $commands{$pid} = undef;
    }
    if (!exists $files{$pid}){
        $files{$pid} = {fileName => undef,
                        content => ''
                        };
    }
    my $file = $files{$pid};
    if (!defined $file->{fileName} || $file->{fileName} ne $infos->{fileName}){
        $file->{content} = $infos->{fileContent};
        $file->{fileName} = $infos->{fileName};
    }
    return $pid;
}

#=method  setRunningProcessInfo
#
#C<setRunningProcessInfo($pid);>
#update the process info when we send the 'continue' command because the process won't update its status until it id finished or it reached a breakpoint
#
#=cut

sub setRunningProcessInfo {
    my ($pid) = @_;
    my $processInfo = $processesInfos{$pid};

    my $programInfo = { 
        pid         => $processInfo->{pid} ,
        name        => $processInfo->{name} , 
        line        => '??',
        subroutine  => '??',
        package     => '??',
        fileName    => '??',
        finished    =>  $processInfo->{finished},
        halted      =>  0,
        stackTrace  => [],
        variables   => {},
        result      => '',
        fileContent => $processInfo->{fileContent} , 
        breakPointVersion => $processInfo->{breakPointVersion},
        lastEvalCommand => '',
        lastEvalResult => '',
       lastUpdateTime  => [Time::HiRes::gettimeofday()],
    };
    $processesInfos{$pid} = $programInfo;
}

#=method  getDebuggingInfos
#
#return a hash containg all debugging info + details for $pid
#
#=cut
sub getDebuggingInfos {

bin/debugServer.pl  view on Meta::CPAN

    my $returnedData = {sourceFileName      => undef,
                        sourceFileContent   => undef};

    $returnedData->{processesInfo} = \%processesInfos;

    $returnedData->{requestedBreakpoints} = $breakPoints ;
    $returnedData->{effectiveBreakpoints} = $effectiveBreakpoints;


    if (defined $pid && exists $files{$pid}){
        my $file = $files{$pid};

        $returnedData->{sourceFileName } = $file->{fileName};
        $returnedData->{sourceFileContent} = $file->{fileContent};
    }

    return $returnedData;
}

sub setBreakPoint{
    my ($command)=@_;
    my $file = $command->{arg1};
    my $lineNumber = $command->{arg2}; 
    if (! File::Spec->file_name_is_absolute( $file )){
        $file =  File::Spec->rel2abs( $file ) ;
    }

    $breakPointVersion ++;
    $breakPoints->{$file}{$lineNumber} = 1;#condition always true for now
}


#suspend process identified with $pid
sub suspend{
    my ($pid)=@_;

    if ($processesInfos{$pid}{halted} == 0){
        my $processSignaled = kill ( 2 => $pid); #send SIGINT to force process to halt 
    }
}

sub removeBreakPoint{
    my ($command)=@_;
    my $file = $command->{arg1};
    my $lineNumber = $command->{arg2}; 

    $breakPointVersion ++;
    if (exists $breakPoints->{$file} && exists $breakPoints->{$file}{$lineNumber}){
        delete $breakPoints->{$file}{$lineNumber};
    }
}

sub trace($){
    my ($text)=@_;
    open (my $fh,">>","./trace.log");
    $text = "[$$]".$text."\n";
    print $fh $text;
    close $fh;
}

sub updateEffectiveBreakpoints{
    my ($effectiveBreakpointsList) = @_;

    for my $breakpoint (@{$effectiveBreakpointsList}){
        my $file=                 $breakpoint->{file};                  
        my $requestedLineNumber =                 $breakpoint->{requestedLineNumber};
        my $effectiveLineNumber=  $breakpoint->{effectiveLineNumber};
        $effectiveBreakpoints->{$file}->{$requestedLineNumber} = $effectiveLineNumber ;
        if ($effectiveLineNumber != $requestedLineNumber){
            #we are in the case where where the requested line number wasn't on a breakable line, we correct the breakpoints info
            #only %effectiveBreakpoints keep informations about invalid breakpoints
            $effectiveBreakpoints->{$file}->{$effectiveLineNumber} = $effectiveLineNumber;
            delete $breakPoints->{$file}{$requestedLineNumber};
            $breakPoints->{$file}{$effectiveLineNumber} = 1;#condition always true for now
        }
    }
}

my $lastProcessCheck = [Time::HiRes::gettimeofday()];
sub checkProcessAlive(){
    if (Time::HiRes::tv_interval ( $lastProcessCheck)< 1){
        return; #nothing to do for now
    }

    foreach my $pid (keys %processesInfos){
        if (Time::HiRes::tv_interval ($processesInfos{$pid}{lastUpdateTime}) > 1.5 ){
             my $processSignaled = kill ( 0 => $pid); #send no signal to check process alive
             if ($processSignaled){
                $processesInfos{$pid}{lastUpdateTime} = [Time::HiRes::gettimeofday()];
             }
         }
    }
    $lastProcessCheck = [Time::HiRes::gettimeofday()];
}

#=method  propagateBreakPoints
#
#propagate new breakpoints to all processes; running processes are interrupted so they update their breakpoints.
#
#=cut
sub propagateBreakPoints {
    if ($lastBreakPointsUpdate == $breakPointVersion){
        return;
    }
    foreach my $pid (keys %processesInfos){
        if ($processesInfos{$pid}{breakPointVersion} != $lastBreakPointsUpdate
         && $processesInfos{$pid}{halted} == 0){
             $commands{$pid} = { command => $Devel::Debug::Server::RUN_COMMAND };
             my $processSignaled = kill ( 2 => $pid); #send SIGINT to force breakpoints refresh
             if ($processSignaled){
                $processesInfos{$pid}{lastUpdateTime} = [Time::HiRes::gettimeofday()];
             }
         }
    }
    $lastBreakPointsUpdate = $breakPointVersion;
}


#The main loop
print "server is started...\n";