diff --git a/Changes b/Changes index 5dd4631..8db562e 100644 --- a/Changes +++ b/Changes @@ -8,6 +8,7 @@ Revision history for Perl-LanguageServer - $#foo is now correctly evaluated inside of debugger console - Default debug configuration is now automatically provided without the need to create a launch.json first (#103) + - Add Option cacheDir to specify location of cache dir (#113) - Fix: Debugger outputted invalid thread reference causes "no such coroutine" message, so watchs and code from the debug console is not expanded properly diff --git a/clients/vscode/perl/package.json b/clients/vscode/perl/package.json index 8873501..abdcdec 100644 --- a/clients/vscode/perl/package.json +++ b/clients/vscode/perl/package.json @@ -94,6 +94,11 @@ "default": null, "description": "directories to ignore, defaults to .vscode, .git, .svn" }, + "perl.cacheDir": { + "type": "string", + "default": null, + "description": "directory for caching of parsed symbols, if the directory does not exists, it will be created, defaults to ${workspace}/.vscode/perl-lang. This should be one unqiue directory per project and an absolute path." + }, "perl.showLocalVars": { "type": "boolean", "default": false, diff --git a/lib/Perl/LanguageServer.pm b/lib/Perl/LanguageServer.pm index f1c600c..9f9f9bb 100644 --- a/lib/Perl/LanguageServer.pm +++ b/lib/Perl/LanguageServer.pm @@ -29,11 +29,11 @@ Perl::LanguageServer - Language Server and Debug Protocol Adapter for Perl =head1 VERSION -Version 2.2.0 +Version 2.3.0 =cut -our $VERSION = '2.2.0'; +our $VERSION = '2.3.0'; =head1 SYNOPSIS diff --git a/lib/Perl/LanguageServer/Methods/workspace.pm b/lib/Perl/LanguageServer/Methods/workspace.pm index 4ecd5c6..67d42be 100644 --- a/lib/Perl/LanguageServer/Methods/workspace.pm +++ b/lib/Perl/LanguageServer/Methods/workspace.pm @@ -80,6 +80,17 @@ sub _rpcnot_didChangeConfiguration $workspace -> show_local_vars ($workspace -> config -> {showLocalVars}) ; $workspace -> disable_cache ($workspace -> config -> {disableCache}) ; + + if ($req -> params -> {settings}{perl}{cacheDir}) + { + $workspace -> state_dir ($req -> params -> {settings}{perl}{cacheDir}) ; + } + else + { + $workspace -> clear_state_dir + } + + $workspace -> mkpath ($workspace -> state_dir) ; # force build state dir async { diff --git a/lib/Perl/LanguageServer/Workspace.pm b/lib/Perl/LanguageServer/Workspace.pm index c669cda..824bc42 100644 --- a/lib/Perl/LanguageServer/Workspace.pm +++ b/lib/Perl/LanguageServer/Workspace.pm @@ -1,381 +1,382 @@ -package Perl::LanguageServer::Workspace ; - -use 5.006; -use strict; -use Moose ; - -use File::Basename ; -use Coro ; -use Coro::AIO ; -use Data::Dump qw{dump} ; - -with 'Perl::LanguageServer::SyntaxChecker' ; -with 'Perl::LanguageServer::Parser' ; - -no warnings 'uninitialized' ; - -# --------------------------------------------------------------------------- - -has 'config' => - ( - isa => 'HashRef', - is => 'ro' - ) ; - -has 'is_shutdown' => - ( - isa => 'Bool', - is => 'rw', - default => 0, - ) ; - -has 'files' => - ( - isa => 'HashRef', - is => 'rw', - default => sub { {} }, - ) ; - -has 'folders' => - ( - isa => 'HashRef', - is => 'rw', - default => sub { {} }, - ) ; - -has 'symbols' => - ( - isa => 'HashRef', - is => 'rw', - default => sub { {} }, - ) ; - -has 'path_map' => - ( - isa => 'Maybe[ArrayRef]', - is => 'rw' - ) ; - -has 'file_filter_regex' => - ( - isa => 'Str', - is => 'rw', - default => '(?:\.pm|\.pl)$', - ) ; - -has 'ignore_dir' => - ( - isa => 'HashRef', - is => 'rw', - default => sub { { '.git' => 1, '.svn' => 1, '.vscode' => 1 } }, - ) ; - -has 'perlcmd' => - ( - isa => 'Str', - is => 'rw', - default => $^X, - ) ; - -has 'perlinc' => - ( - isa => 'Maybe[ArrayRef]', - is => 'rw', - ) ; - -has 'show_local_vars' => - ( - isa => 'Maybe[Bool]', - is => 'rw', - ) ; - - -has 'parser_channel' => - ( - is => 'rw', - isa => 'Coro::Channel', - default => sub { Coro::Channel -> new } - ) ; - -has 'state_dir' => - ( - is => 'rw', - isa => 'Str', - lazy_build => 1, - ) ; - -has 'disable_cache' => - ( - isa => 'Maybe[Bool]', - is => 'rw', - ) ; - -# --------------------------------------------------------------------------- - -sub logger - { - my $self = shift ; - - Perl::LanguageServer::logger (undef, @_) ; - } - -# ---------------------------------------------------------------------------- - - -sub mkpath - { - my ($self, $dir) = @_ ; - - aio_stat ($dir) ; - if (! -d _) - { - $self -> mkpath (dirname($dir)) ; - aio_mkdir ($dir, 0755) and die "Cannot make $dir ($!)" ; - } - } - -# --------------------------------------------------------------------------- - -sub _build_state_dir - { - my ($self) = @_ ; - - my $root = $self -> config -> {rootUri} || 'file:///tmp' ; - my $rootpath = substr ($self -> uri_client2server ($root), 7) ; - $rootpath =~ s#^/(\w)%3A/#$1:/# ; - $rootpath .= '/.vscode/perl-lang' ; - print STDERR "state_dir = $rootpath\n" ; - $self -> mkpath ($rootpath) ; - - return $rootpath ; - } - -# --------------------------------------------------------------------------- - - -sub shutdown - { - my ($self) = @_ ; - - $self -> is_shutdown (1) ; - } - -# --------------------------------------------------------------------------- - -sub uri_server2client - { - my ($self, $uri) = @_ ; - - my $map = $self -> path_map ; - return $uri if (!$map) ; - - #print STDERR ">uri_server2client $uri\n", dump($map), "\n" ; - foreach my $m (@$map) - { - last if ($uri =~ s/$m->[0]/$m->[1]/) ; - } - #print STDERR " path_map ; - return $uri if (!$map) ; - - #print STDERR ">uri_client2server $uri\n" ; - foreach my $m (@$map) - { - last if ($uri =~ s/$m->[1]/$m->[0]/) ; - } - #print STDERR " path_map ; - return $fn if (!$map) ; - - foreach my $m (@$map) - { - #print STDERR "file_server2client $m->[2] -> $m->[3] : $fn\n" ; - last if ($fn =~ s/$m->[2]/$m->[3]/) ; - } - - return $fn ; - } - -# --------------------------------------------------------------------------- - -sub file_client2server - { - my ($self, $fn) = @_ ; - - my $map = $self -> path_map ; - return $fn if (!$map) ; - - $fn =~ s/\\/\//g ; - - foreach my $m (@$map) - { - #print STDERR "file_client2server $m->[3] -> $m->[2] : $fn\n" ; - last if ($fn =~ s/$m->[3]/$m->[2]/) ; - } - - return $fn ; - } - -# --------------------------------------------------------------------------- - -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 set_workspace_folders - { - my ($self, $workspace_folders) = @_ ; - - my $folders = $self -> folders ; - foreach my $ws (@$workspace_folders) - { - my $diruri = $self -> uri_client2server ($ws -> {uri}) ; - - my $dir = substr ($diruri, 7) ; - $dir =~ s#^/(\w)%3A/#$1:/# ; - $folders -> {$ws -> {uri}} = $dir ; - } - } - -# --------------------------------------------------------------------------- - -sub add_diagnostic_messages - { - my ($self, $server, $uri, $source, $messages, $version) = @_ ; - - my $files = $self -> files ; - $files -> {$uri}{messages}{$source} = $messages ; - $files -> {$uri}{messages_version} = $version if (defined ($version)); - - # make sure all old messages associated with this uri are cleaned up - my %diags = ( map { $_ => [] } @{$files -> {$uri}{diags} || ['-'] } ) ; - foreach my $src (keys %{$files -> {$uri}{messages}}) - { - my $msgs = $files -> {$uri}{messages}{$src} ; - if ($msgs && @$msgs) - { - my $line ; - my $lineno = 0 ; - my $filename ; - my $lastline = 1 ; - my $msg ; - my $severity ; - foreach $line (@$msgs) - { - ($filename, $lineno, $severity, $msg) = @$line ; - if ($lineno) - { - if ($msg) - { - my $diag = - { - # range: Range; - # severity?: DiagnosticSeverity; - # code?: number | string; - # codeDescription?: CodeDescription; - # source?: string; - # message: string; - # tags?: DiagnosticTag[]; - # relatedInformation?: DiagnosticRelatedInformation[]; - # data?: unknown; - - # DiagnosticSeverity - # const Error: 1 = 1; - # const Warning: 2 = 2; - # const Information: 3 = 3; - # const Hint: 4 = 4; - - # DiagnosticTag - # * Clients are allowed to render diagnostics with this tag faded out - # * instead of having an error squiggle. - # export const Unnecessary: 1 = 1; - # * Clients are allowed to rendered diagnostics with this tag strike through. - # export const Deprecated: 2 = 2; - - # DiagnosticRelatedInformation - # * Represents a related message and source code location for a diagnostic. - # * This should be used to point to code locations that cause or are related to - # * a diagnostics, e.g when duplicating a symbol in a scope. - # - # * The location of this related diagnostic information. - # location: Location; - # * The message of this related diagnostic information. - # message: string; - - range => { start => { line => $lineno-1, character => 0 }, end => { line => $lineno+0, character => 0 }}, - ($severity?(severity => $severity + 0):()), - message => $msg, - source => $src, - } ; - $diags{$filename} ||= [] ; - push @{$diags{$filename}}, $diag ; - } - $lastline = $lineno ; - $lineno = 0 ; - $msg = '' ; - } - } - } - } - $files -> {$uri}{diags} = [keys %diags] ; - - foreach my $filename (keys %diags) - { - foreach my $filename (keys %diags) - { - my $fnuri = !$filename || $filename eq '-'?$uri:$self -> uri_server2client ('file://' . $filename) ; - my $result = - { - method => 'textDocument/publishDiagnostics', - params => - { - uri => $fnuri, - diagnostics => $diags{$filename}, - }, - } ; - - $server -> send_notification ($result) ; - } - } - } - -# --------------------------------------------------------------------------- - - -1 ; - +package Perl::LanguageServer::Workspace ; + +use 5.006; +use strict; +use Moose ; + +use File::Basename ; +use Coro ; +use Coro::AIO ; +use Data::Dump qw{dump} ; + +with 'Perl::LanguageServer::SyntaxChecker' ; +with 'Perl::LanguageServer::Parser' ; + +no warnings 'uninitialized' ; + +# --------------------------------------------------------------------------- + +has 'config' => + ( + isa => 'HashRef', + is => 'ro' + ) ; + +has 'is_shutdown' => + ( + isa => 'Bool', + is => 'rw', + default => 0, + ) ; + +has 'files' => + ( + isa => 'HashRef', + is => 'rw', + default => sub { {} }, + ) ; + +has 'folders' => + ( + isa => 'HashRef', + is => 'rw', + default => sub { {} }, + ) ; + +has 'symbols' => + ( + isa => 'HashRef', + is => 'rw', + default => sub { {} }, + ) ; + +has 'path_map' => + ( + isa => 'Maybe[ArrayRef]', + is => 'rw' + ) ; + +has 'file_filter_regex' => + ( + isa => 'Str', + is => 'rw', + default => '(?:\.pm|\.pl)$', + ) ; + +has 'ignore_dir' => + ( + isa => 'HashRef', + is => 'rw', + default => sub { { '.git' => 1, '.svn' => 1, '.vscode' => 1 } }, + ) ; + +has 'perlcmd' => + ( + isa => 'Str', + is => 'rw', + default => $^X, + ) ; + +has 'perlinc' => + ( + isa => 'Maybe[ArrayRef]', + is => 'rw', + ) ; + +has 'show_local_vars' => + ( + isa => 'Maybe[Bool]', + is => 'rw', + ) ; + + +has 'parser_channel' => + ( + is => 'rw', + isa => 'Coro::Channel', + default => sub { Coro::Channel -> new } + ) ; + +has 'state_dir' => + ( + is => 'rw', + isa => 'Str', + lazy_build => 1, + clearer => 'clear_state_dir', + ) ; + +has 'disable_cache' => + ( + isa => 'Maybe[Bool]', + is => 'rw', + ) ; + +# --------------------------------------------------------------------------- + +sub logger + { + my $self = shift ; + + Perl::LanguageServer::logger (undef, @_) ; + } + +# ---------------------------------------------------------------------------- + + +sub mkpath + { + my ($self, $dir) = @_ ; + + aio_stat ($dir) ; + if (! -d _) + { + $self -> mkpath (dirname($dir)) ; + aio_mkdir ($dir, 0755) and die "Cannot make $dir ($!)" ; + } + } + +# --------------------------------------------------------------------------- + +sub _build_state_dir + { + my ($self) = @_ ; + + my $root = $self -> config -> {rootUri} || 'file:///tmp' ; + my $rootpath = substr ($self -> uri_client2server ($root), 7) ; + $rootpath =~ s#^/(\w)%3A/#$1:/# ; + $rootpath .= '/.vscode/perl-lang' ; + print STDERR "state_dir = $rootpath\n" ; + $self -> mkpath ($rootpath) ; + + return $rootpath ; + } + +# --------------------------------------------------------------------------- + + +sub shutdown + { + my ($self) = @_ ; + + $self -> is_shutdown (1) ; + } + +# --------------------------------------------------------------------------- + +sub uri_server2client + { + my ($self, $uri) = @_ ; + + my $map = $self -> path_map ; + return $uri if (!$map) ; + + #print STDERR ">uri_server2client $uri\n", dump($map), "\n" ; + foreach my $m (@$map) + { + last if ($uri =~ s/$m->[0]/$m->[1]/) ; + } + #print STDERR " path_map ; + return $uri if (!$map) ; + + #print STDERR ">uri_client2server $uri\n" ; + foreach my $m (@$map) + { + last if ($uri =~ s/$m->[1]/$m->[0]/) ; + } + #print STDERR " path_map ; + return $fn if (!$map) ; + + foreach my $m (@$map) + { + #print STDERR "file_server2client $m->[2] -> $m->[3] : $fn\n" ; + last if ($fn =~ s/$m->[2]/$m->[3]/) ; + } + + return $fn ; + } + +# --------------------------------------------------------------------------- + +sub file_client2server + { + my ($self, $fn) = @_ ; + + my $map = $self -> path_map ; + return $fn if (!$map) ; + + $fn =~ s/\\/\//g ; + + foreach my $m (@$map) + { + #print STDERR "file_client2server $m->[3] -> $m->[2] : $fn\n" ; + last if ($fn =~ s/$m->[3]/$m->[2]/) ; + } + + return $fn ; + } + +# --------------------------------------------------------------------------- + +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 set_workspace_folders + { + my ($self, $workspace_folders) = @_ ; + + my $folders = $self -> folders ; + foreach my $ws (@$workspace_folders) + { + my $diruri = $self -> uri_client2server ($ws -> {uri}) ; + + my $dir = substr ($diruri, 7) ; + $dir =~ s#^/(\w)%3A/#$1:/# ; + $folders -> {$ws -> {uri}} = $dir ; + } + } + +# --------------------------------------------------------------------------- + +sub add_diagnostic_messages + { + my ($self, $server, $uri, $source, $messages, $version) = @_ ; + + my $files = $self -> files ; + $files -> {$uri}{messages}{$source} = $messages ; + $files -> {$uri}{messages_version} = $version if (defined ($version)); + + # make sure all old messages associated with this uri are cleaned up + my %diags = ( map { $_ => [] } @{$files -> {$uri}{diags} || ['-'] } ) ; + foreach my $src (keys %{$files -> {$uri}{messages}}) + { + my $msgs = $files -> {$uri}{messages}{$src} ; + if ($msgs && @$msgs) + { + my $line ; + my $lineno = 0 ; + my $filename ; + my $lastline = 1 ; + my $msg ; + my $severity ; + foreach $line (@$msgs) + { + ($filename, $lineno, $severity, $msg) = @$line ; + if ($lineno) + { + if ($msg) + { + my $diag = + { + # range: Range; + # severity?: DiagnosticSeverity; + # code?: number | string; + # codeDescription?: CodeDescription; + # source?: string; + # message: string; + # tags?: DiagnosticTag[]; + # relatedInformation?: DiagnosticRelatedInformation[]; + # data?: unknown; + + # DiagnosticSeverity + # const Error: 1 = 1; + # const Warning: 2 = 2; + # const Information: 3 = 3; + # const Hint: 4 = 4; + + # DiagnosticTag + # * Clients are allowed to render diagnostics with this tag faded out + # * instead of having an error squiggle. + # export const Unnecessary: 1 = 1; + # * Clients are allowed to rendered diagnostics with this tag strike through. + # export const Deprecated: 2 = 2; + + # DiagnosticRelatedInformation + # * Represents a related message and source code location for a diagnostic. + # * This should be used to point to code locations that cause or are related to + # * a diagnostics, e.g when duplicating a symbol in a scope. + # + # * The location of this related diagnostic information. + # location: Location; + # * The message of this related diagnostic information. + # message: string; + + range => { start => { line => $lineno-1, character => 0 }, end => { line => $lineno+0, character => 0 }}, + ($severity?(severity => $severity + 0):()), + message => $msg, + source => $src, + } ; + $diags{$filename} ||= [] ; + push @{$diags{$filename}}, $diag ; + } + $lastline = $lineno ; + $lineno = 0 ; + $msg = '' ; + } + } + } + } + $files -> {$uri}{diags} = [keys %diags] ; + + foreach my $filename (keys %diags) + { + foreach my $filename (keys %diags) + { + my $fnuri = !$filename || $filename eq '-'?$uri:$self -> uri_server2client ('file://' . $filename) ; + my $result = + { + method => 'textDocument/publishDiagnostics', + params => + { + uri => $fnuri, + diagnostics => $diags{$filename}, + }, + } ; + + $server -> send_notification ($result) ; + } + } + } + +# --------------------------------------------------------------------------- + + +1 ; +