package Perl::LanguageServer::DebuggerProcess ;
use 5.006;
use strict;
use Moose ;
use Encode::Locale;
use Encode;
use File::Basename ;
use Coro ;
use Coro::AIO ;
use Data::Dump qw{dump} ;
with 'Perl::LanguageServer::IO' ;
no warnings 'uninitialized' ;
our $session_cnt = 1 ;
# ---------------------------------------------------------------------------
has 'program' =>
(
isa => 'Str',
is => 'ro'
) ;
has 'args' =>
(
isa => 'ArrayRef | Str',
is => 'ro',
default => sub { [] },
) ;
has 'env' =>
(
isa => 'HashRef',
is => 'ro',
default => sub { {} },
) ;
has 'cwd' =>
(
isa => 'Maybe[Str]',
is => 'ro',
) ;
has 'sudo_user' =>
(
isa => 'Maybe[Str]',
is => 'ro',
) ;
has 'use_taint_for_debug' =>
(
isa => 'Bool',
is => 'rw'
) ;
has 'path_map' =>
(
isa => 'Maybe[ArrayRef]',
is => 'rw'
) ;
has 'stop_on_entry' =>
(
isa => 'Bool',
is => 'ro'
) ;
has 'reload_modules' =>
(
isa => 'Bool',
is => 'ro'
) ;
has 'session_id' =>
(
isa => 'Str',
is => 'ro'
) ;
has 'type' =>
(
isa => 'Str',
is => 'ro'
) ;
has 'debug_adapter' =>
(
isa => 'Perl::LanguageServer',
is => 'rw',
weak_ref => 1,
) ;
has 'pid' =>
(
isa => 'Int',
is => 'rw'
) ;
# ---------------------------------------------------------------------------
sub BUILDARGS
{
my ($class, $args) = @_ ;
$args -> {env} = { @{$args -> {env}} } if (exists $args -> {env} && ref ($args -> {env}) eq 'ARRAY') ;
$args -> {reload_modules} = delete $args -> {reloadModules}?1:0 ;
$args -> {stop_on_entry} = delete $args -> {stopOnEntry}?1:0 ;
$args -> {session_id} = delete $args -> {__sessionId} || $session_cnt ;
$args -> {sudo_user} = delete $args -> {sudoUser} ;
$args -> {use_taint_for_debug} = delete $args -> {useTaintForDebug} ;
my $map = delete $args -> {pathMap} ;
if ($map)
{
my $fn ;
foreach (@$map)
{
$fn = $_ -> [0] ;
$fn =~ s/^file:// ;
$fn =~ s/^\/\/\//\// ;
$_ -> [2] ||= $fn ;
$fn = $_ -> [1] ;
$fn =~ s/^file:// ;
$fn =~ s/^\/\/\//\// ;
$_ -> [3] ||= $fn ;
}
$args -> {path_map} = $map ;
}
$session_cnt++ ;
return $args ;
}
# ---------------------------------------------------------------------------
sub logger
{
my $self = shift ;
$self -> debug_adapter -> logger (@_) ;
}
# ---------------------------------------------------------------------------
sub file_server2client
{
my ($self, $workspace, $fn) = @_ ;
return $workspace -> file_server2client ($fn, $self -> path_map) ;
}
# ---------------------------------------------------------------------------
sub file_client2server
{
my ($self, $workspace, $fn) = @_ ;
return $workspace -> file_client2server ($fn, $self -> path_map) ;
}
# ---------------------------------------------------------------------------
sub add_path_mapping
{
my ($self, $fn_server, $fn_client) = @_ ;
my $map = $self -> path_map ;
$map = $self -> path_map ([]) if (!$map) ;
foreach my $m (@$map)
{
#print STDERR "add file_server2client $m->[2] -> $m->[3]\n" ;
return if ($fn_server eq $m->[2]) ;
}
unshift @$map, ['file://' . $fn_server, 'file://' . $fn_client, $fn_server, $fn_client] ;
return ;
}
# ---------------------------------------------------------------------------
sub send_event
{
my ($self, $event, $body) = @_ ;
$self -> debug_adapter -> send_event ($event, $body) ;
}
# ---------------------------------------------------------------------------
sub launch
{
my ($self, $workspace, $cmd) = @_ ;
my $fn = $self -> file_client2server ($workspace, $self -> program) ;
my $pid ;
{
local %ENV = %ENV ;
my @sudoargs ;
if ($self->sudo_user)
{
push @sudoargs, "sudo", "-u", $self->sudo_user ;
}
foreach (keys %{$self -> env})
{
$ENV{$_} = $self -> env -> {$_} ;
push @sudoargs, "$_=" . $self -> env -> {$_} if $self->sudo_user;
}
my $cwd ;
if ($self -> cwd)
{
my $dir = $self -> cwd ;
$dir =~ s/'//g ;
$cwd = " chdir '$dir'; " ;
}
my $inc = $workspace -> perlinc ;
my @inc ;
@inc = map { ('-I', $_)} @$inc if ($inc) ;
$ENV{PLSDI_REMOTE} = '127.0.0.1:' . $self -> debug_adapter -> listen_port ;
$ENV{PLSDI_OPTIONS} = $self -> reload_modules?'reload_modules':'' ;
$ENV{PERL5DB} = 'BEGIN { $| = 1 ; ' . $cwd . 'require Perl::LanguageServer::DebuggerInterface; DB::DB(); }' ;
$ENV{PLSDI_SESSION}= $self -> session_id ;
if ($self->sudo_user)
{
push @sudoargs, "PLSDI_REMOTE=$ENV{PLSDI_REMOTE}" ;
push @sudoargs, "PLSDI_OPTIONS=$ENV{PLSDI_OPTIONS}" ;
push @sudoargs, "PERL5DB=$ENV{PERL5DB}" ;
push @sudoargs, "PLSDI_SESSION=$ENV{PLSDI_SESSION}" ;
}
if ($self->use_taint_for_debug)
{
push @inc, "-T" ;
}
if (ref $self -> args) # ref is array
{
$pid = $self -> run_async ([@sudoargs, $cmd, @inc, '-d', $fn, @{$self -> args}]) ;
}
else # no ref is string
{
$pid = $self -> run_async (join (' ', @sudoargs, $cmd, @inc, '-d', $fn, $self -> args)) ;
}
}
$self -> pid ($pid) ;
$self -> send_event ('process',
{
name => $self -> program,
systemProcessId => $pid,
isLocalProcess => JSON::true(),
startMethod => 'launch',
}) ;
return ;
}
# ---------------------------------------------------------------------------
sub signal
{
my ($self, $signal) = @_ ;
return if (!$self -> pid) ;
$self -> logger ("Send signal $signal to debuggee\n") ;
kill $signal, $self -> pid ;
}
# ---------------------------------------------------------------------------
sub on_stdout
{
my ($self, $data) = @_ ;
foreach my $line (split /\r?\n/, $data)
{
$line = decode(locale => $line);
$self -> send_event ('output', { category => 'stdout', output => $line . "\r\n" }) ;
}
}
# ---------------------------------------------------------------------------
sub on_stderr
{
my ($self, $data) = @_ ;
foreach my $line (split /\r?\n/, $data)
{
$line = decode(locale => $line);
$self -> send_event ('output', { category => 'stderr', output => $line . "\r\n" }) ;
}
}
# ---------------------------------------------------------------------------
sub on_exit
{
my ($self, $data) = @_ ;
$self -> send_event ('terminated') ;
$self -> send_event ('exited', { exitCode => ($data>>8)&0xff }) ;
}
# ---------------------------------------------------------------------------
1 ;