package Perl::LanguageServer::Methods::DebugAdapterInterface ; use Moose::Role ; use Coro ; use Coro::AIO ; use Data::Dump qw{dump} ; use Perl::LanguageServer::DevTool ; use Perl::LanguageServer::DebuggerProcess ; no warnings 'uninitialized' ; our $reqseq = 1_000_000_000 ; # --------------------------------------------------------------------------- has 'debugger_process' => ( isa => 'Perl::LanguageServer::DebuggerProcess', is => 'rw' ) ; has 'debug_adapter' => ( isa => 'Perl::LanguageServer', is => 'rw', weak_ref => 1, predicate => 'has_debug_adapter', ) ; has 'cmd_queue' => ( is => 'ro', isa => 'Coro::Channel', default => sub { Coro::Channel -> new } ) ; has 'cmd_in_progress' => ( is => 'rw', isa => 'Maybe[HashRef]', ) ; has 'initialized' => ( is => 'rw', isa => 'Bool', default => 0 ) ; has 'responses' => ( isa => 'HashRef', is => 'rw', default => sub { {} }, ) ; # --------------------------------------------------------------------------- sub send_event { my ($self, $event, $body) = @_ ; $self -> debug_adapter -> send_event ($event, $body) ; } # --------------------------------------------------------------------------- sub send_request { my ($self) = @_ ; return if ($self -> cmd_in_progress) ; my $channel = $self -> cmd_queue ; return if ($channel -> size == 0) ; my $req = $channel -> get () ; $self -> cmd_in_progress ($req) ; $self -> send_notification ($req, $self, "<--- To debuggee: ") ; return ; } # --------------------------------------------------------------------------- sub request { my ($self, $req) = @_ ; my $seq = $reqseq++ ; $req -> {seq} = $seq ; my $channels = $self -> responses ; local $channels -> {$seq} = Coro::Channel -> new ; my $channel = $self -> cmd_queue ; $channel -> put ($req) ; $self -> send_request () ; my $ret = $channels -> {$seq} -> get ; $self -> send_request () ; return $ret ; } # --------------------------------------------------------------------------- sub _dapreq_di_response { my ($self, $workspace, $req) = @_ ; my $seq = - $req -> id ; my $cmd = $self -> cmd_in_progress ; my $cmdseq = $cmd?$cmd -> {seq}:'' ; my $channels = $self -> responses ; $self -> logger ("di_response seq = $seq lastcmd seq = $cmdseq channels = ", dump([keys %$channels]), " queue size = ", $self -> cmd_queue -> size, "\n") ; return if (!exists $channels -> {$seq}) ; $channels -> {$seq} -> put ($req -> params) ; $self -> cmd_in_progress (undef) ; $self -> send_request () ; return ; } # --------------------------------------------------------------------------- sub _dapreq_di_break { my ($self, $workspace, $req) = @_ ; $self -> log_prefix ('DAI') ; $self -> log_req_txt ('---> From debuggee: ') ; my $debug_adapter = $Perl::LanguageServer::Methods::DebugAdapter::debug_adapters{$req -> params -> {session_id}} ; die "no debug_adapter for session " . $req -> params -> {session_id} if (!$debug_adapter) ; $debug_adapter -> running (0) ; $self -> logger ("session_id = " . $req -> params -> {session_id} . "\n") ; #$self -> logger ("debug_adapter = ", dump ($debug_adapter), "\n") ; $self -> debug_adapter ($debug_adapter) ; $self -> debugger_process ($debug_adapter -> debugger_process) ; $debug_adapter -> debug_adapter_interface ($self) ; my $initialized = $self -> initialized ; my $reason = $req -> params -> {reason} ; $self -> logger ("_dapreq_di_break reason = $reason initialized = $initialized temp_break = ", $debug_adapter -> in_temp_break, " stop_on_entry = ", $self -> debugger_process -> stop_on_entry,"\n") ; return if ($reason eq 'pause' && $debug_adapter -> in_temp_break) ; $debug_adapter -> in_temp_break (0) ; $reason ||= $initialized?'breakpoint':'entry' ; $debug_adapter -> clear_non_thread_ids ; if ($initialized || $self -> debugger_process -> stop_on_entry) { $self -> send_event ('stopped', { reason => $reason, threadId => $debug_adapter -> getid (0, $req -> params -> {thread_ref}) || 1, preserveFocusHint => JSON::false (), allThreadsStopped => JSON::true (), }) ; } if (!$initialized) { $self -> send_event ('initialized') ; } $self -> initialized (1) ; return ; } # --------------------------------------------------------------------------- sub _dapreq_di_loadedfile { my ($self, $workspace, $req) = @_ ; $self -> log_prefix ('DAI') ; if (!$self -> has_debug_adapter) { my $debug_adapter = $Perl::LanguageServer::Methods::DebugAdapter::debug_adapters{$req -> params -> {session_id}} ; die "no debug_adapter for session " . $req -> params -> {session_id} if (!$debug_adapter) ; $self -> logger ("session_id = " . $req -> params -> {session_id} . "\n") ; #$self -> logger ("debug_adapter = ", dump ($debug_adapter), "\n") ; $self -> debug_adapter ($debug_adapter) ; $self -> debugger_process ($debug_adapter -> debugger_process) ; $debug_adapter -> debug_adapter_interface ($self) ; } $self -> send_event ('loadedSource', { reason => $req -> params -> {reason}, source => $req -> params -> {source}, }) ; return ; } # --------------------------------------------------------------------------- sub _dapreq_di_breakpoints { my ($self, $workspace, $req) = @_ ; $self -> log_prefix ('DAI') ; if ($req -> params -> {real_filename}) { $workspace -> add_path_mapping ($req -> params -> {real_filename}, $workspace -> file_server2client ($req -> params -> {req_filename})) } foreach my $bp (@{$req -> params -> {breakpoints}}) { $self -> send_event ('breakpoint', { reason => 'changed', breakpoint => { verified => $bp -> [2]?JSON::true ():JSON::false (), message => $bp -> [3], line => $bp -> [4]+0, id => $bp -> [6]+0, source => { path => $workspace -> file_server2client ($bp -> [5]) }, } }) ; } return ; } # --------------------------------------------------------------------------- 1 ;