view release on metacpan or  search on metacpan

bin/debugServer.pl  view on Meta::CPAN

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

while (1) {
    # Wait for the next request from client
    my $message = $responder->recv();

    if (defined $message){
        my $requestStr = $message->data();
        my $request = Storable::thaw($requestStr);
        my $messageToSend = undef;

        if ($request->{type} eq $Devel::Debug::Server::DEBUG_PROCESS_TYPE){ #message from a debugged process
            my $pid = updateProcessInfo($request);
            
            my $commandInfos= $commands{$pid};
            $messageToSend = {command       =>  $commandInfos,
                              fileName      => $files{$pid}->{fileName},
                              breakPoints  => $breakPoints,
                              breakPointVersion => $breakPointVersion,
                          };
            $commands{$pid} = undef; #don't send the same command twice
            if (defined $commandInfos  && defined $commandInfos->{command}
                 && $commandInfos->{command} eq $Devel::Debug::Server::RUN_COMMAND){
               setRunningProcessInfo($pid); 
            }
        } elsif ($request->{type} eq $Devel::Debug::Server::DEBUG_GUI_TYPE){ #message from the GUI
            my $command = $request->{command};
            my $pid = $request->{pid};