File Coverage

blib/lib/Perl/LanguageServer/Workspace.pm
Criterion Covered Total %
statement 23 104 22.1
branch 0 32 0.0
condition 0 16 0.0
subroutine 8 18 44.4
pod 0 9 0.0
total 31 179 17.3


line stmt bran cond sub pod time code
1             package Perl::LanguageServer::Workspace ;
2              
3 1     1   28 use 5.006;
  1         3  
4 1     1   5 use strict;
  1         2  
  1         20  
5 1     1   5 use Moose ;
  1         2  
  1         8  
6              
7 1     1   6339 use File::Basename ;
  1         2  
  1         76  
8 1     1   6 use Coro ;
  1         2  
  1         84  
9 1     1   8 use Coro::AIO ;
  1         2  
  1         360  
10 1     1   7 use Data::Dump qw{dump} ;
  1         7  
  1         65  
11              
12             with 'Perl::LanguageServer::SyntaxChecker' ;
13             with 'Perl::LanguageServer::Parser' ;
14              
15 1     1   23 no warnings 'uninitialized' ;
  1         3  
  1         1793  
16              
17             # ---------------------------------------------------------------------------
18              
19             has 'config' =>
20             (
21             isa => 'HashRef',
22             is => 'ro'
23             ) ;
24              
25             has 'is_shutdown' =>
26             (
27             isa => 'Bool',
28             is => 'rw',
29             default => 0,
30             ) ;
31              
32             has 'files' =>
33             (
34             isa => 'HashRef',
35             is => 'rw',
36             default => sub { {} },
37             ) ;
38              
39             has 'folders' =>
40             (
41             isa => 'HashRef',
42             is => 'rw',
43             default => sub { {} },
44             ) ;
45              
46             has 'symbols' =>
47             (
48             isa => 'HashRef',
49             is => 'rw',
50             default => sub { {} },
51             ) ;
52              
53             has 'path_map' =>
54             (
55             isa => 'Maybe[ArrayRef]',
56             is => 'rw'
57             ) ;
58              
59             has 'file_filter_regex' =>
60             (
61             isa => 'Str',
62             is => 'rw',
63             default => '(?:\.pm|\.pl)$',
64             ) ;
65              
66             has 'ignore_dir' =>
67             (
68             isa => 'HashRef',
69             is => 'rw',
70             default => sub { { '.git' => 1, '.svn' => 1, '.vscode' => 1 } },
71             ) ;
72              
73             has 'perlcmd' =>
74             (
75             isa => 'Str',
76             is => 'rw',
77             default => $^X,
78             ) ;
79              
80             has 'perlinc' =>
81             (
82             isa => 'Maybe[ArrayRef]',
83             is => 'rw',
84             ) ;
85              
86             has 'use_taint_for_syntax_check' =>
87             (
88             isa => 'Maybe[Bool]',
89             is => 'rw'
90             ) ;
91              
92             has 'show_local_vars' =>
93             (
94             isa => 'Maybe[Bool]',
95             is => 'rw',
96             ) ;
97              
98              
99             has 'parser_channel' =>
100             (
101             is => 'rw',
102             isa => 'Coro::Channel',
103             default => sub { Coro::Channel -> new }
104             ) ;
105              
106             has 'state_dir' =>
107             (
108             is => 'rw',
109             isa => 'Str',
110             lazy_build => 1,
111             clearer => 'clear_state_dir',
112             ) ;
113              
114             has 'disable_cache' =>
115             (
116             isa => 'Maybe[Bool]',
117             is => 'rw',
118             ) ;
119              
120             # ---------------------------------------------------------------------------
121              
122             sub logger
123             {
124 0     0 0   my $self = shift ;
125              
126 0           Perl::LanguageServer::logger (undef, @_) ;
127             }
128              
129             # ----------------------------------------------------------------------------
130              
131              
132             sub mkpath
133             {
134 0     0 0   my ($self, $dir) = @_ ;
135              
136 0           aio_stat ($dir) ;
137 0 0         if (! -d _)
138             {
139 0           $self -> mkpath (dirname($dir)) ;
140 0 0         aio_mkdir ($dir, 0755) and die "Cannot make $dir ($!)" ;
141             }
142             }
143              
144             # ---------------------------------------------------------------------------
145              
146             sub _build_state_dir
147             {
148 0     0     my ($self) = @_ ;
149              
150 0   0       my $root = $self -> config -> {rootUri} || 'file:///tmp' ;
151 0           my $rootpath = substr ($self -> uri_client2server ($root), 7) ;
152 0           $rootpath =~ s#^/(\w)%3A/#$1:/# ;
153 0           $rootpath .= '/.vscode/perl-lang' ;
154 0           print STDERR "state_dir = $rootpath\n" ;
155 0           $self -> mkpath ($rootpath) ;
156              
157 0           return $rootpath ;
158             }
159              
160             # ---------------------------------------------------------------------------
161              
162              
163             sub shutdown
164             {
165 0     0 0   my ($self) = @_ ;
166              
167 0           $self -> is_shutdown (1) ;
168             }
169              
170             # ---------------------------------------------------------------------------
171              
172             sub uri_server2client
173             {
174 0     0 0   my ($self, $uri) = @_ ;
175              
176 0           my $map = $self -> path_map ;
177 0 0         return $uri if (!$map) ;
178              
179             #print STDERR ">uri_server2client $uri\n", dump($map), "\n" ;
180 0           foreach my $m (@$map)
181             {
182 0 0         last if ($uri =~ s/$m->[0]/$m->[1]/) ;
183             }
184             #print STDERR "<uri_server2client $uri\n" ;
185              
186 0           return $uri ;
187             }
188              
189             # ---------------------------------------------------------------------------
190              
191             sub uri_client2server
192             {
193 0     0 0   my ($self, $uri) = @_ ;
194              
195 0           my $map = $self -> path_map ;
196 0 0         return $uri if (!$map) ;
197              
198             #print STDERR ">uri_client2server $uri\n" ;
199 0           foreach my $m (@$map)
200             {
201 0 0         last if ($uri =~ s/$m->[1]/$m->[0]/) ;
202             }
203             #print STDERR "<uri_client2server $uri\n" ;
204              
205 0           return $uri ;
206             }
207              
208             # ---------------------------------------------------------------------------
209              
210             sub file_server2client
211             {
212 0     0 0   my ($self, $fn, $map) = @_ ;
213              
214 0   0       $map ||= $self -> path_map ;
215 0 0         return $fn if (!$map) ;
216              
217 0           foreach my $m (@$map)
218             {
219             #print STDERR "file_server2client $m->[2] -> $m->[3] : $fn\n" ;
220 0 0         last if ($fn =~ s/$m->[2]/$m->[3]/) ;
221             }
222              
223 0           return $fn ;
224             }
225              
226             # ---------------------------------------------------------------------------
227              
228             sub file_client2server
229             {
230 0     0 0   my ($self, $fn, $map) = @_ ;
231              
232 0   0       $map ||= $self -> path_map ;
233 0 0         return $fn if (!$map) ;
234              
235 0           $fn =~ s/\\/\//g ;
236              
237 0           foreach my $m (@$map)
238             {
239             #print STDERR "file_client2server $m->[3] -> $m->[2] : $fn\n" ;
240 0 0         last if ($fn =~ s/$m->[3]/$m->[2]/) ;
241             }
242              
243 0           return $fn ;
244             }
245              
246             # ---------------------------------------------------------------------------
247              
248             sub set_workspace_folders
249             {
250 0     0 0   my ($self, $workspace_folders) = @_ ;
251              
252 0           my $folders = $self -> folders ;
253 0           foreach my $ws (@$workspace_folders)
254             {
255 0           my $diruri = $self -> uri_client2server ($ws -> {uri}) ;
256              
257 0           my $dir = substr ($diruri, 7) ;
258 0           $dir =~ s#^/(\w)%3A/#$1:/# ;
259 0           $folders -> {$ws -> {uri}} = $dir ;
260             }
261             }
262              
263             # ---------------------------------------------------------------------------
264              
265             sub add_diagnostic_messages
266             {
267 0     0 0   my ($self, $server, $uri, $source, $messages, $version) = @_ ;
268              
269 0           my $files = $self -> files ;
270 0           $files -> {$uri}{messages}{$source} = $messages ;
271 0 0         $files -> {$uri}{messages_version} = $version if (defined ($version));
272              
273             # make sure all old messages associated with this uri are cleaned up
274 0           my %diags = ( map { $_ => [] } @{$files -> {$uri}{diags} } ) ;
  0            
  0            
275 0           foreach my $src (keys %{$files -> {$uri}{messages}})
  0            
276             {
277 0           my $msgs = $files -> {$uri}{messages}{$src} ;
278 0 0 0       if ($msgs && @$msgs)
279             {
280 0           my $line ;
281 0           my $lineno = 0 ;
282 0           my $filename ;
283 0           my $lastline = 1 ;
284 0           my $msg ;
285             my $severity ;
286 0           foreach $line (@$msgs)
287             {
288 0           ($filename, $lineno, $severity, $msg) = @$line ;
289 0 0         if ($lineno)
290             {
291 0 0         if ($msg)
292             {
293 0 0         my $diag =
294             {
295             # range: Range;
296             # severity?: DiagnosticSeverity;
297             # code?: number | string;
298             # codeDescription?: CodeDescription;
299             # source?: string;
300             # message: string;
301             # tags?: DiagnosticTag[];
302             # relatedInformation?: DiagnosticRelatedInformation[];
303             # data?: unknown;
304              
305             # DiagnosticSeverity
306             # const Error: 1 = 1;
307             # const Warning: 2 = 2;
308             # const Information: 3 = 3;
309             # const Hint: 4 = 4;
310              
311             # DiagnosticTag
312             # * Clients are allowed to render diagnostics with this tag faded out
313             # * instead of having an error squiggle.
314             # export const Unnecessary: 1 = 1;
315             # * Clients are allowed to rendered diagnostics with this tag strike through.
316             # export const Deprecated: 2 = 2;
317              
318             # DiagnosticRelatedInformation
319             # * Represents a related message and source code location for a diagnostic.
320             # * This should be used to point to code locations that cause or are related to
321             # * a diagnostics, e.g when duplicating a symbol in a scope.
322             #
323             # * The location of this related diagnostic information.
324             # location: Location;
325             # * The message of this related diagnostic information.
326             # message: string;
327              
328             range => { start => { line => $lineno-1, character => 0 }, end => { line => $lineno+0, character => 0 }},
329             ($severity?(severity => $severity + 0):()),
330             message => $msg,
331             source => $src,
332             } ;
333 0   0       $diags{$filename} ||= [] ;
334 0           push @{$diags{$filename}}, $diag ;
  0            
335             }
336 0           $lastline = $lineno ;
337 0           $lineno = 0 ;
338 0           $msg = '' ;
339             }
340             }
341             }
342             }
343 0           $files -> {$uri}{diags} = [keys %diags] ;
344              
345 0           foreach my $filename (keys %diags)
346             {
347 0 0 0       my $fnuri = !$filename || $filename eq '-'?$uri:$self -> uri_server2client ('file://' . $filename) ;
348             my $result =
349             {
350             method => 'textDocument/publishDiagnostics',
351             params =>
352             {
353             uri => $fnuri,
354 0           diagnostics => $diags{$filename},
355             },
356             } ;
357              
358 0           $server -> send_notification ($result) ;
359             }
360             }
361              
362             # ---------------------------------------------------------------------------
363              
364              
365             1 ;
366