Perl-LanguageServer-2.6.2/0000755000000000000000000000000014541561347014043 5ustar rootrootPerl-LanguageServer-2.6.2/t/0000755000000000000000000000000014541561337014305 5ustar rootrootPerl-LanguageServer-2.6.2/t/00-load.t0000644000000000000000000000037413302357546015631 0ustar rootroot#!perl -T use 5.006; use strict; use warnings; use Test::More; plan tests => 1; BEGIN { use_ok( 'Perl::LanguageServer' ) || print "Bail out!\n"; } diag( "Testing Perl::LanguageServer $Perl::LanguageServer::VERSION, Perl $], $^X" ); Perl-LanguageServer-2.6.2/README.pod0000644000000000000000000003666114541561336015516 0ustar rootroot=head1 Perl::LanguageServer Language Server and Debug Protocol Adapter for Perl =head2 Features =over =item * Language Server =over =item * Syntax checking =item * Symbols in file =item * Symbols in workspace/directory =item * Goto Definition =item * Find References =item * Call Signatures =item * Supports multiple workspace folders =item * Document and selection formatting via perltidy =item * Run on remote system via ssh =item * Run inside docker container =item * Run inside kubernetes =back =item * Debugger =over =item * Run, pause, step, next, return =item * Support for coro threads =item * Breakpoints =item * Conditional breakpoints =item * Breakpoints can be set while program runs and for modules not yet loaded =item * Variable view, can switch to every stack frame or coro thread =item * Set variable =item * Watch variable =item * Tooltips with variable values =item * Evaluate perl code in debuggee, in context of every stack frame of coro thread =item * Automatically reload changed Perl modules while debugging =item * Debug multiple perl programs at once =item * Run on remote system via ssh =item * Run inside docker container =item * Run inside kubernetes =back =back =head2 Requirements You need to install the perl module Perl::LanguageServer to make this extension work, e.g. run C on your target system. Please make sure to always run the newest version of Perl::LanguageServer as well. NOTE: Perl::LanguageServer depend on AnyEvent::AIO and Coro. There is a warning that this might not work with newer Perls. It works fine for Perl::LanguageServer. So just confirm the warning and install it. Perl::LanguageServer depends on other Perl modules. It is a good idea to install most of then with your linux package manager. e.g. on Debian/Ubuntu run: sudo apt install libanyevent-perl libclass-refresh-perl libcompiler-lexer-perl \ libdata-dump-perl libio-aio-perl libjson-perl libmoose-perl libpadwalker-perl \ libscalar-list-utils-perl libcoro-perl sudo cpan Perl::LanguageServer e.g. on Centos 7 run: sudo yum install perl-App-cpanminus perl-AnyEvent-AIO perl-Coro sudo cpanm Class::Refresh sudo cpanm Compiler::Lexer sudo cpanm Hash::SafeKeys sudo cpanm Perl::LanguageServer In case any of the above packages are not available for your os version, just leave them out. The cpan command will install missing dependencies. In case the test fails, when running cpan C, you should try to run C. =head2 Extension Settings This extension contributes the following settings: =over =item * C: enable/disable this extension =item * C: ip address of remote system =item * C: optional, port for ssh to remote system =item * C: user for ssh login =item * C: defaults to ssh on unix and plink on windows =item * C: path of the workspace root on remote system =item * C: defaults to perl =item * C: additional arguments passed to the perl interpreter that starts the LanguageServer =item * C: if true, use taint mode for syntax check =item * C: optional arguments for ssh =item * C: mapping of local to remote paths =item * C: array with paths to add to perl library path. This setting is used by the syntax checker and for the debuggee and also for the LanguageServer itself. =item * C: array for filtering perl file, defaults to [I<.pm,>.pl] =item * C: directories to ignore, defaults to [.vscode, .git, .svn] =item * C: port to use for connection between vscode and debug adapter inside Perl::LanguageServer. =item * C: if debugAdapterPort is in use try ports from debugAdapterPort to debugAdapterPort + debugAdapterPortRange. Default 100. =item * C: if true, show also local variables in symbol view =item * C: Log level 0-2. =item * C: If set, log output is written to the given logfile, instead of displaying it in the vscode output pane. Log output is always appended. Only use during debugging of LanguageServer itself. =item * C: If true, the LanguageServer will not cache the result of parsing source files on disk, so it can be used within readonly directories =item * C: If set Perl::LanguageServer can run inside a container. Options are: 'docker', 'docker-compose', 'kubectl' =item * C: arguments for containerCmd. Varies depending on containerCmd. =item * C: To start a new container, set to 'run', to execute inside an existing container set to 'exec'. Note: kubectl only supports 'exec' =item * C: Image to start or container to exec inside or pod to use =back =head2 Debugger Settings for launch.json =over =item * C: needs to be C =item * C: only C is supported (this is a restriction of perl itself) =item * C: name of this debug configuration =item * C: path to perl program to start =item * C: if true, program will stop on entry =item * C: optional, array or string with arguments for perl program =item * C: optional, object with environment settings =item * C: optional, change working directory before launching the debuggee =item * C: if true, automatically reload changed Perl modules while debugging =item * C: optional, if set run debug process with sudo -u \. =item * C: optional, if true run debug process with -T (taint mode). =item * C: If set debugger runs inside a container. Options are: 'docker', 'docker-compose', 'podman', 'kubectl' =item * C: arguments for containerCmd. Varies depending on containerCmd. =item * C: To start a new container, set to 'run', to debug inside an existing container set to 'exec'. Note: kubectl only supports 'exec' =item * C: Image to start or container to exec inside or pod to use =item * C: mapping of local to remote paths for this debug session (overwrites global C) =back =head2 Remote syntax check & debugging If you developing on a remote machine, you can instruct the Perl::LanguageServer to run on that remote machine, so the correct modules etc. are available for syntax check and debugger is started on the remote machine. To do so set sshAddr and sshUser, preferably in your workspace configuration. Example: "sshAddr": "10.11.12.13", "sshUser": "root" Also set sshWorkspaceRoot, so the local workspace path can be mapped to the remote one. Example: if your local path is \10.11.12.13\share\path\to\ws and on the remote machine you have /path/to/ws "sshWorkspaceRoot": "/path/to/ws" The other possibility is to provide a pathMap. This allows one to having multiple mappings. Examples: "perl.pathMap": [ ["remote uri", "local uri"], ["remote uri", "local uri"] ] "perl.pathMap": [ [ "file:///", "file:///home/systems/mountpoint/" ] ] =head2 Syntax check & debugging inside a container You can run the LanguageServer and/or debugger inside a container by setting C and C. There are more container options, see above. .vscode/settings.json { "perl": { "enable": true, "containerCmd": "docker", "containerName": "perl_container", } } This will start the whole Perl::LanguageServer inside the container. This is espacally helpfull to make syntax check working, if there is a different setup inside and outside the container. In this case you need to tell the Perl::LanguageServer how to map local paths to paths inside the container. This is done by setting C (see above). Example: "perl.pathMap": [ [ "file:///path/inside/the/container", "file:///local/path/outside/the/container" ] ] It's also possible to run the LanguageServer outside the container and only the debugger inside the container. This is especially helpfull, when the container is not always running, while you are editing. To make only the debugger running inside the container, put C, C and C in your C. You can have different setting for each debug session. Normaly the arguments for the C are automatically build. In case you want to use an unsupported C you need to specifiy apropriate C. =head2 FAQ =head3 Working directory is not defined It is not defined what the current working directory is at the start of a perl program. So Perl::LanguageServer makes no assumptions about it. To solve the problem you can set the directory via cwd configuration parameter in launch.json for debugging. =head3 Module not found when debugging or during syntax check If you reference a module with a relative path or if you assume that the current working directory is part of the Perl search path, it will not work. Instead set the perl include path to a fixed absolute path. In your settings.json do something like: "perl.perlInc": [ "/path/a/lib", "/path/b/lib", "/path/c/lib", ], Include path works for syntax check and inside of debugger. C should be an absolute path. =head3 AnyEvent, Coro Warning during install You need to install the AnyEvent::IO and Coro. Just ignore the warning that it might not work. For Perl::LanguageServer it works fine. =head3 'richterger.perl' failed: options.port should be >= 0 and < 65536 Change port setting from string to integer =head3 Error "Can't locate MODULE_NAME" Please make sure the path to the module is in C setting and use absolute path names in the perlInc settings or make sure you are running in the expected directory by setting the C setting in the lauch.json. =head3 ERROR: Unknown perlmethod IsetTraceNotification This is not an issue, that just means that not all features of the debugging protocol are implemented. Also it says ERROR, it's just a warning and you can safely ignore it. =head3 The debugger sometimes stops at random places Upgrade to Version 2.4.0 =head3 Message about Perl::LanguageServer has crashed 5 times This is a problem when more than one instance of Perl::LanguageServer is running. Upgrade to Version 2.4.0 solves this problem. =head3 The program I want to debug needs some input via stdin You can read stdin from a file during debugging. To do so add the following parameter to your C: C<< "args": [ "E", "/path/to/stdin.txt" ] >> e.g. C<< { "type": "perl", "request": "launch", "name": "Perl-Debug", "program": "${workspaceFolder}/${relativeFile}", "stopOnEntry": true, "reloadModules": true, "env": { "REQUEST_METHOD": "POST", "CONTENT_TYPE": "application/x-www-form-urlencoded", "CONTENT_LENGTH": 34 } "args": [ "E", "/path/to/stdin.txt" ] } >> =head3 Carton support If you are using LL to manage dependencies, add the full path to the Carton C dir to your workspace settings file at C<.vscode/settings.json>. For example: =head4 Linux { "perl.perlInc": ["/home/myusername/projects/myprojectname/local/lib/perl5"] } =head4 Mac { "perl.perlInc": ["/Users/myusername/projects/myprojectname/local/lib/perl5"] } =head2 Known Issues Does not yet work on windows, due to issues with reading from stdin. I wasn't able to find a reliable way to do a non-blocking read from stdin on windows. I would be happy, if anyone knows how to do this in Perl. Anyway, Perl::LanguageServer runs without problems inside of Windows Subsystem for Linux (WSL). =head2 Release Notes see CHANGELOG.md =head2 More Info =over =item * Presentation at German Perl Workshop 2020: =back https://github.com/richterger/Perl-LanguageServer/blob/master/docs/Perl-LanguageServer%20und%20Debugger%20f%C3%BCr%20Visual%20Studio%20Code%20u.a.%20Editoren%20-%20Perl%20Workshop%202020.pdf =over =item * Github: https://github.com/richterger/Perl-LanguageServer =item * MetaCPAN: https://metacpan.org/release/Perl-LanguageServer =back For reporting bugs please use GitHub issues. =head2 References This is a Language Server and Debug Protocol Adapter for Perl It implements the Language Server Protocol which provides syntax-checking, symbol search, etc. Perl to various editors, for example Visual Studio Code or Atom. https://microsoft.github.io/language-server-protocol/specification It also implements the Debug Adapter Protocol, which allows debugging with various editors/includes https://microsoft.github.io/debug-adapter-protocol/overview To use both with Visual Studio Code, install the extension "perl" https://marketplace.visualstudio.com/items?itemName=richterger.perl Any comments and patches are welcome. =head2 LICENSE AND COPYRIGHT Copyright 2018-2022 Gerald Richter. This program is free software; you can redistribute it and/or modify it under the terms of the Artistic License (2.0). You may obtain a copy of the full license at: LL Any use, modification, and distribution of the Standard or Modified Versions is governed by this Artistic License. By using, modifying or distributing the Package, you accept this license. Do not use, modify, or distribute the Package, if you do not accept this license. If your Modified Version has been derived from a Modified Version made by someone other than you, you are nevertheless required to ensure that your Modified Version complies with the requirements of this license. This license does not grant you the right to use any trademark, service mark, tradename, or logo of the Copyright Holder. This license includes the non-exclusive, worldwide, free-of-charge patent license to make, have made, use, offer to sell, sell, import and otherwise transfer the Package with respect to any patent claims licensable by the Copyright Holder that are necessarily infringed by the Package. If you institute patent litigation (including a cross-claim or counterclaim) against any party alleging that the Package constitutes direct or contributory patent infringement, then this Artistic License to you shall terminate on the date that such litigation is filed. Disclaimer of Warranty: THE PACKAGE IS PROVIDED BY THE COPYRIGHT HOLDER AND CONTRIBUTORS "AS IS' AND WITHOUT ANY EXPRESS OR IMPLIED WARRANTIES. THE IMPLIED WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE, OR NON-INFRINGEMENT ARE DISCLAIMED TO THE EXTENT PERMITTED BY YOUR LOCAL LAW. UNLESS REQUIRED BY LAW, NO COPYRIGHT HOLDER OR CONTRIBUTOR WILL BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING IN ANY WAY OUT OF THE USE OF THE PACKAGE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. Perl-LanguageServer-2.6.2/LICENSE0000644000000000000000000000373414335707057015060 0ustar rootrootvscode-extension-perl LICENSE AND COPYRIGHT Copyright 2018-2022 Gerald Richter. This program is free software; you can redistribute it and/or modify it under the terms of the the Artistic License (2.0). You may obtain a copy of the full license at: L Any use, modification, and distribution of the Standard or Modified Versions is governed by this Artistic License. By using, modifying or distributing the Package, you accept this license. Do not use, modify, or distribute the Package, if you do not accept this license. If your Modified Version has been derived from a Modified Version made by someone other than you, you are nevertheless required to ensure that your Modified Version complies with the requirements of this license. This license does not grant you the right to use any trademark, service mark, tradename, or logo of the Copyright Holder. This license includes the non-exclusive, worldwide, free-of-charge patent license to make, have made, use, offer to sell, sell, import and otherwise transfer the Package with respect to any patent claims licensable by the Copyright Holder that are necessarily infringed by the Package. If you institute patent litigation (including a cross-claim or counterclaim) against any party alleging that the Package constitutes direct or contributory patent infringement, then this Artistic License to you shall terminate on the date that such litigation is filed. Disclaimer of Warranty: THE PACKAGE IS PROVIDED BY THE COPYRIGHT HOLDER AND CONTRIBUTORS "AS IS' AND WITHOUT ANY EXPRESS OR IMPLIED WARRANTIES. THE IMPLIED WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE, OR NON-INFRINGEMENT ARE DISCLAIMED TO THE EXTENT PERMITTED BY YOUR LOCAL LAW. UNLESS REQUIRED BY LAW, NO COPYRIGHT HOLDER OR CONTRIBUTOR WILL BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING IN ANY WAY OUT OF THE USE OF THE PACKAGE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. Perl-LanguageServer-2.6.2/META.json0000644000000000000000000000324614541561347015471 0ustar rootroot{ "abstract" : "Language Server and Debug Protocol Adapter for Perl", "author" : [ "grichter " ], "dynamic_config" : 1, "generated_by" : "ExtUtils::MakeMaker version 7.34, CPAN::Meta::Converter version 2.150010", "license" : [ "artistic_2" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : 2 }, "name" : "Perl-LanguageServer", "no_index" : { "directory" : [ "t", "inc" ] }, "prereqs" : { "build" : { "requires" : { "Test::More" : "0" } }, "configure" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "runtime" : { "requires" : { "AnyEvent" : "0", "AnyEvent::AIO" : "0", "Class::Refresh" : "0", "Compiler::Lexer" : "0.23", "Coro" : "0", "Data::Dump" : "0", "Encode::Locale" : "0", "Hash::SafeKeys" : "0", "IO::AIO" : "0", "JSON" : "0", "Moose" : "0", "PadWalker" : "0", "Scalar::Util" : "0", "perl" : "5.016" } } }, "release_status" : "stable", "resources" : { "bugtracker" : { "web" : "https://github.com/richterger/Perl-LanguageServer/issues" }, "repository" : { "type" : "git", "url" : "https://github.com/richterger/Perl-LanguageServer.git", "web" : "https://github.com/richterger/Perl-LanguageServer" } }, "version" : "v2.6.2", "x_serialization_backend" : "JSON::PP version 2.97001" } Perl-LanguageServer-2.6.2/MANIFEST0000644000000000000000000000152414541561347015176 0ustar rootrootChanges.pod lib/Perl/LanguageServer.pm lib/Perl/LanguageServer/DebuggerBridge.pm lib/Perl/LanguageServer/DebuggerInterface.pm lib/Perl/LanguageServer/DebuggerProcess.pm lib/Perl/LanguageServer/DevTool.pm lib/Perl/LanguageServer/IO.pm lib/Perl/LanguageServer/Methods.pm lib/Perl/LanguageServer/Methods/DebugAdapter.pm lib/Perl/LanguageServer/Methods/DebugAdapterInterface.pm lib/Perl/LanguageServer/Methods/textDocument.pm lib/Perl/LanguageServer/Methods/workspace.pm lib/Perl/LanguageServer/Parser.pm lib/Perl/LanguageServer/Req.pm lib/Perl/LanguageServer/SyntaxChecker.pm lib/Perl/LanguageServer/Workspace.pm Makefile.PL MANIFEST This list of files README.pod LICENSE t/00-load.t META.yml Module YAML meta-data (added by MakeMaker) META.json Module JSON meta-data (added by MakeMaker) Perl-LanguageServer-2.6.2/Changes.pod0000644000000000000000000001716514541561336016127 0ustar rootroot=head1 Change Log =head2 2.6.2 C<2023-12-23> =over =item * avoid given/when/smartmatch because these features are deprecated in perl 5.38 (#199) [real-dam] =back =head2 2.6.1 C<2023-07-26> =over =item * Fix: Formatting with perltidy was broken in 2.6.0 =back =head2 2.6.0 C<2023-07-23> =over =item * Add debug setting for running as different user. See sudoUser setting. (#174) [wielandp] =item * Allow to use a string for debuggee arguments. (#149, #173) [wielandp] =item * Add stdin redirection (#166) [wielandp] =item * Add link to issues to META files (#168) [szabgab/issues] =item * Add support for podman =item * Add support for run Perl::LanguageServer outside, but debugger inside a container =item * Add setting useTaintForSyntaxCheck. If true, use taint mode for syntax check (#172) [wielandp] =item * Add setting useTaintForDebug. If true, use taint mode inside debugger (#181) [wielandp] =item * Add debug adapter request C, which allows to display source of eval or file that are not available to vscode (#180) [wielandp] =item * Fix: Spelling (#170, #171) [pkg-perl-tools] =item * Fix: Convert charset encoding of debugger output according to current locale (#167) [wielandp] =item * Fix: Fix diagnostic notifications override on clients (based on #185) [bmeneg] =back =head2 2.5.0 C<2023-02-05> =over =item * Set minimal Perl version to 5.16 (#91) =item * Per default environment from vscode will be passed to debuggee, syntax check and perltidy. =item * Add configuration C to not pass environment variables. =item * Support for C and C settings via LanguageServer protocol and not only via command line options (#97) [schellj] =item * Fix: "No DB::DB routine defined" (#91) [peterdragon] =item * Fix: Typos and spelling in README (#159) [dseynhae] =item * Fix: Update call to gensym(), to fix 'strict subs' error (#164) [KohaAloha] =item * Convert identention from tabs to spaces and remove trailing whitespaces =back =head2 2.4.0 C<2022-11-18> =over =item * Choose a different port for debugAdapterPort if it is already in use. This avoids trouble with starting C if another instance of C is running on the same machine (thanks to hakonhagland) =item * Add configuration C, for choosing range of port for dynamic port assignment =item * Add support for using LanguageServer and debugger inside a Container. Currently docker containers und containers running inside kubernetes are supported. =item * When starting debugger session and C is false, do not switch to sourefile where debugger would stop, when C is true. =item * Added some FAQs in README =item * Fix: Debugger stopps at random locations =item * Fix: debugAdapterPort is now numeric =item * Fix: debugging loop with each statement (#107) =item * Fix: display of arrays in variables pane on mac (#120) =item * Fix: encoding for C (#127) =item * Fix: return error if C fails, so text is not removed by failing formatting request (#87) =item * Fix: FindBin does not work when checking syntax (#16) =back =head2 2.3.0 C<2021-09-26> =over =item * Arguments section in Variable lists now C<@ARGV> and C<@_> during debugging (#105) =item * C<@_> is now correctly evaluated inside of debugger console =item * C<$#foo> is now correctly evaluated inside of debugger console =item * Default debug configuration is now automatically provided without the need to create a C first (#103) =item * Add Option C to specify location of cache dir (#113) =item * Fix: Debugger outputted invalid thread reference causes "no such coroutine" message, so watchs and code from the debug console is not expanded properly =item * Fix: LanguageServer hangs when multiple request send at once from VSCode to LanguageServer =item * Fix: cwd parameter for debugger in launch.json had no effect (#99) =item * Fix: Correctly handle paths with drive letters on windows =item * Fix: sshArgs parameter was not declared as array (#109) =item * Disable syntax check on windows, because it blocks the whole process when running on windows, until handling of child's processes is fixed =item * Fixed spelling (#86,#96,#101) [chrstphrchvz,davorg,aluaces] =back =head2 2.2.0 C<2021-02-21> =over =item * Parser now supports Moose method modifieres before, after and around, so they can be used in symbol view and within reference search =item * Support Format Document and Format Selection via perltidy =item * Add logFile config option =item * Add perlArgs config option to pass options to Perl interpreter. Add some documentation for config options. =item * Add disableCache config option to make LanguageServer usable with readonly directories. =item * updated dependencies package.json & package-lock.json =item * Fix deep recursion in SymbolView/Parser which was caused by function prototypes. Solves also #65 =item * Fix duplicate req id's that caused cleanup of still running threads which in turn caused the LanguageServer to hang =item * Prevent dereferencing an undefined value (#63) [Heiko Jansen] =item * Fix datatype of cwd config options (#47) =item * Use perlInc setting also for LanguageServer itself (based only pull request #54 from ALANVF) =item * Catch Exceptions during display of variables inside debugger =item * Fix detecting duplicate LanguageServer processes =item * Fix spelling in documentation (#56) [Christopher Chavez] =item * Remove notice about Compiler::Lexer 0.22 bugs (#55) [Christopher Chavez] =item * README: Typo and grammar fixes. Add Carton lib path instructions. (#40) [szTheory] =item * README: Markdown code block formatting (#42) [szTheory] =item * Makefile.PL: add META_MERGE with GitHub info (#32) [Christopher Chavez] =item * search.cpan.org retired, replace with metacpan.org (#31) [Christopher Chavez] =back =head2 2.1.0 C<2020-06-27> =over =item * Improve Symbol Parser (fix parsing of anonymous subs) =item * showLocalSymbols =item * function names in breadcrump =item * Signature Help for function/method arguments =item * Add Presentation on Perl Workshop 2020 to repos =item * Remove Compiler::Lexer from distribution since version is available on CPAN =item * Make stdout unbuffered while debugging =item * Make debugger use perlInc setting =item * Fix fileFilter setting =item * Sort Arrays numerically in variables view of debugger =item * Use rootUri if workspaceFolders not given =item * Fix env config setting =item * Recongnice changes in config of perlCmd =back =head2 2.0.2 C<2020-01-22> =over =item * Plugin: Fix command line parameters for plink =item * Perl::LanguageServer: Fix handling of multiple parallel request, improve symlink handling, add support for UNC paths in path mapping, improve logging for logLevel = 1 =back =head2 2.0.1 C<2020-01-14> Added support for reloading Perl module while debugging, make log level configurable, make sure tooltips don't call functions =head2 2.0.0 C<2020-01-01> Added Perl debugger =head2 0.9.0 C<2019-05-03> Fix issues in the Perl part, make sure to update Perl::LanguageServer from cpan =head2 0.0.3 C<2018-09-08> Fix issue with not reading enough from stdin, which caused LanguageServer to hang sometimes =head2 0.0.2 C<2018-07-21> Fix quitting issue when starting Perl::LanguageServer, more fixes are in the Perl part =head2 0.0.1 C<2018-07-13> Initial Version Perl-LanguageServer-2.6.2/Makefile.PL0000644000000000000000000000453714420734115016015 0ustar rootrootuse v5.16; use strict; use warnings; use ExtUtils::MakeMaker; use FindBin ; use File::Basename ; use Cwd; =pod my $mydir = getcwd; my $lexer_make = $FindBin::Bin . '/p5-Compiler-Lexer/Build.PL' ; my $lexer_inst = $FindBin::Bin . '/p5-Compiler-Lexer/Build' ; if (-e $lexer_make) { print "Running $lexer_make to build included Compiler::Lexer\n\n" ; my $dir = dirname ($lexer_make) ; chdir $dir ; #system ("cd '$dir' && perl '$lexer_make'") and my $rc ; if (!($rc = system ('perl', $lexer_make))) { print "Install Compiler::Lexer\n\n" ; $rc = system ($lexer_inst, 'install') ; } if ($rc) { warn "Cannot run perl Build.PL for Compiler::Lexer. You need to install Compiler::Lexer from Github (do not use version 0.22)" ; } chdir $mydir ; } =cut WriteMakefile( NAME => 'Perl::LanguageServer', AUTHOR => q{grichter }, VERSION_FROM => 'lib/Perl/LanguageServer.pm', ABSTRACT_FROM => 'lib/Perl/LanguageServer.pm', LICENSE => 'artistic_2', META_MERGE => { 'meta-spec' => { version => 2 }, resources => { repository => { type => 'git', url => 'https://github.com/richterger/Perl-LanguageServer.git', web => 'https://github.com/richterger/Perl-LanguageServer', }, bugtracker => { web => 'https://github.com/richterger/Perl-LanguageServer/issues' }, }, }, PL_FILES => {}, MIN_PERL_VERSION => '5.016', CONFIGURE_REQUIRES => { 'ExtUtils::MakeMaker' => '0', }, BUILD_REQUIRES => { 'Test::More' => '0', }, PREREQ_PM => { 'Moose' => '0', 'AnyEvent' => '0', 'IO::AIO' => '0', 'AnyEvent::AIO' => '0', 'Coro' => '0', 'JSON' => '0', 'Data::Dump' => '0', 'PadWalker' => '0', 'Scalar::Util' => '0', 'Class::Refresh' => '0', 'Compiler::Lexer' => '0.23', 'Hash::SafeKeys' => '0', 'Encode::Locale' => '0', }, dist => { COMPRESS => 'gzip -9f', SUFFIX => 'gz', }, clean => { FILES => 'Perl-LanguageServer-*' }, ); Perl-LanguageServer-2.6.2/lib/0000755000000000000000000000000014541562103014600 5ustar rootrootPerl-LanguageServer-2.6.2/lib/Perl/0000755000000000000000000000000014541561337015512 5ustar rootrootPerl-LanguageServer-2.6.2/lib/Perl/LanguageServer.pm0000644000000000000000000011712314541561336020766 0ustar rootrootpackage Perl::LanguageServer; use v5.16; use strict ; use Moose ; use Moose::Util qw( apply_all_roles ); use Coro ; use Coro::AIO ; use Coro::Handle ; use AnyEvent; use AnyEvent::Socket ; use JSON ; use Data::Dump qw{dump pp} ; use IO::Select ; use Perl::LanguageServer::Req ; use Perl::LanguageServer::Workspace ; with 'Perl::LanguageServer::Methods' ; with 'Perl::LanguageServer::IO' ; no warnings 'uninitialized' ; =head1 NAME Perl::LanguageServer - Language Server and Debug Protocol Adapter for Perl =head1 VERSION Version 2.5.0 =cut our $VERSION = '2.6.2'; =head1 SYNOPSIS This is a Language Server and Debug Protocol Adapter for Perl It implements the Language Server Protocol which provides syntax-checking, symbol search, etc. Perl to various editors, for example Visual Studio Code or Atom. L It also implements the Debug Adapter Protocol, which allow debugging with various editors/includes L Should work with any Editor/IDE that support the Language-Server-Protocol. To use both with Visual Studio Code, install the extension "perl" Any comments and patches are welcome. =cut our $json = JSON -> new -> utf8(1) -> ascii(1) ; our $jsonpretty = JSON -> new -> utf8(1) -> ascii(1) -> pretty (1) ; our %running_reqs ; our %running_coros ; our $exit ; our $workspace ; our $dev_tool ; our $debug1 = 0 ; our $debug2 = 0 ; our $log_file ; our $client_version ; our $reqseq = 1_000_000_000 ; has 'channel' => ( is => 'ro', isa => 'Coro::Channel', default => sub { Coro::Channel -> new } ) ; has 'debug' => ( is => 'rw', isa => 'Int', default => 1, ) ; has 'listen_port' => ( is => 'rw', isa => 'Maybe[Int]', ) ; has 'roles' => ( is => 'rw', isa => 'HashRef', default => sub { {} }, ) ; has 'out_semaphore' => ( is => 'ro', isa => 'Coro::Semaphore', default => sub { Coro::Semaphore -> new } ) ; has 'log_prefix' => ( is => 'rw', isa => 'Str', default => 'LS', ) ; has 'log_req_txt' => ( is => 'rw', isa => 'Str', default => '---> Request: ', ) ; # --------------------------------------------------------------------------- sub logger { my $self = shift ; my $src ; if (!defined ($_[0]) || ref ($_[0])) { $src = shift ; } $src = $self if (!$src) ; if ($log_file) { open my $fh, '>>', $log_file or warn "$log_file : $!" ; print $fh $src?$src -> log_prefix . ': ':'', @_ ; close $fh ; } else { print STDERR $src?$src -> log_prefix . ': ':'', @_ ; } } # --------------------------------------------------------------------------- sub send_notification { my ($self, $notification, $src, $txt) = @_ ; $txt ||= "<--- Notification: " ; $notification -> {jsonrpc} = '2.0' ; my $outdata = $json -> encode ($notification) ; my $guard = $self -> out_semaphore -> guard ; use bytes ; my $len = length($outdata) ; my $wrdata = "Content-Length: $len\r\nContent-Type: application/vscode-jsonrpc; charset=utf-8\r\n\r\n$outdata" ; $self -> _write ($wrdata) ; if ($debug1) { $wrdata =~ s/\r//g ; $self -> logger ($src, $txt, $jsonpretty -> encode ($notification), "\n") if ($debug1) ; } } # --------------------------------------------------------------------------- sub call_method { my ($self, $reqdata, $req, $id) = @_ ; my $method = $req -> is_dap?$reqdata -> {command}:$reqdata -> {method} ; my $module ; my $name ; if ($method =~ /^(\w+)\/(\w+)$/) { $module = $1 ; $name = $2 ; } elsif ($method =~ /^(\w+)$/) { $name = $1 ; } elsif ($method =~ /^\$\/(\w+)$/) { $name = $1 ; } else { die "Unknown method $method" ; } $module = $req -> type eq 'dbgint'?'DebugAdapterInterface':'DebugAdapter' if ($req -> is_dap) ; my $base_package = __PACKAGE__ . '::Methods' ; my $package = $base_package ; $package .= '::' . $module if ($module) ; my $fn = $package . '.pm' ; $fn =~ s/::/\//g ; if (!exists $INC{$fn} || !exists $self -> roles -> {$fn}) { #$self -> logger (dump (\%INC), "\n") ; $self -> logger ("apply_all_roles ($self, $package, $fn)\n") ; apply_all_roles ($self, $package) ; $self -> roles -> {$fn} = 1 ; } my $perlmethod ; if ($req -> is_dap) { $perlmethod = '_dapreq_' . $name ; } else { $perlmethod = (defined($id)?'_rpcreq_':'_rpcnot_') . $name ; } $self -> logger ("method=$perlmethod\n") if ($debug1) ; die "Unknown perlmethod $perlmethod" if (!$self -> can ($perlmethod)) ; no strict ; return $self -> $perlmethod ($workspace, $req) ; use strict ; } # --------------------------------------------------------------------------- sub process_req { my ($self, $id, $reqdata) = @_ ; my $xid = $id ; $xid ||= $reqseq++ ; $running_coros{$xid} = async { my $req_guard = Guard::guard { $self -> logger ("done handle_req id=$xid\n") if ($debug1) ; delete $running_reqs{$xid} ; delete $running_coros{$xid} ; }; my $type = $reqdata -> {type} ; my $is_dap = $type?1:0 ; $type = defined ($id)?'request':'notification' if (!$type) ; $self -> logger ("handle_req id=$id\n") if ($debug1) ; my $req = Perl::LanguageServer::Req -> new ({ id => $id, is_dap => $is_dap, type => $type, params => $is_dap?$reqdata -> {arguments} || {}:$reqdata -> {params} || {}}) ; $running_reqs{$xid} = $req ; my $rsp ; my $outdata ; my $outjson ; eval { $rsp = $self -> call_method ($reqdata, $req, $id) ; $id = undef if (!$rsp) ; if ($req -> is_dap) { $outjson = { request_seq => -$id, seq => -$id, command => $reqdata -> {command}, success => JSON::true, type => 'response', $rsp?(body => $rsp):()} ; } else { $outjson = { id => $id, jsonrpc => '2.0', result => $rsp} if ($rsp) ; } $outdata = $json -> encode ($outjson) if ($outjson) ; } ; if ($@) { $self -> logger ("ERROR: $@\n") ; if ($req -> is_dap) { $outjson = { request_seq => -$id, command => $reqdata -> {command}, success => JSON::false, message => "$@", , type => 'response'} ; } else { $outjson = { id => $id, jsonrpc => '2.0', error => { code => -32001, message => "$@" }} ; } $outdata = $json -> encode ($outjson) if ($outjson) ; } if (defined($id)) { my $guard = $self -> out_semaphore -> guard ; use bytes ; my $len = length ($outdata) ; my $wrdata = "Content-Length: $len\r\nContent-Type: application/vscode-jsonrpc; charset=utf-8\r\n\r\n$outdata" ; my $sum = 0 ; my $cnt ; while ($sum < length ($wrdata)) { $cnt = $self -> _write ($wrdata, undef, $sum) ; die "write_error ($!)" if ($cnt <= 0) ; $sum += $cnt ; } if ($debug1) { $wrdata =~ s/\r//g ; $self -> logger ("<--- Response: ", $jsonpretty -> encode ($outjson), "\n") ; } } } ; } # --------------------------------------------------------------------------- sub mainloop { my ($self) = @_ ; my $buffer = '' ; while (!$exit) { use bytes ; my %header ; my $line ; my $cnt ; my $loop ; header: while (1) { $self -> logger ("start aio read, buffer len = " . length ($buffer) . "\n") if ($debug2) ; if ($loop) { $cnt = $self -> _read (\$buffer, 8192, length ($buffer), undef, 1) ; $self -> logger ("end aio read cnt=$cnt, buffer len = " . length ($buffer) . "\n") if ($debug2) ; die "read_error reading headers ($!)" if ($cnt < 0) ; return if ($cnt == 0) ; } while ($buffer =~ s/^(.*?)\R//) { $line = $1 ; $self -> logger ("line=<$line>\n") if ($debug2) ; last header if ($line eq '') ; $header{$1} = $2 if ($line =~ /(.+?):\s*(.+)/) ; } $loop = 1 ; } my $len = $header{'Content-Length'} ; return 1 if ($len == 0); my $data ; #$self -> logger ("len=$len len buffer=", length ($buffer), "\n") if ($debug2) ; while ($len > length ($buffer)) { $cnt = $self -> _read (\$buffer, $len - length ($buffer), length ($buffer)) ; #$self -> logger ("cnt=$cnt len=$len len buffer=", length ($buffer), "\n") if ($debug2) ; die "read_error reading data ($!)" if ($cnt < 0) ; return if ($cnt == 0) ; } if ($len == length ($buffer)) { $data = $buffer ; $buffer = '' ; } elsif ($len < length ($buffer)) { $data = substr ($buffer, 0, $len) ; $buffer = substr ($buffer, $len) ; } else { die "to few data bytes" ; } $self -> logger ("read data=", $data, "\n") if ($debug2) ; $self -> logger ("read header=", dump (\%header), "\n") if ($debug2) ; my $reqdata ; $reqdata = $json -> decode ($data) if ($data) ; if ($debug1) { $self -> logger ($self -> log_req_txt, $jsonpretty -> encode ($reqdata), "\n") ; } my $id = $reqdata -> {type}?-$reqdata -> {seq}:$reqdata -> {id}; $self -> process_req ($id, $reqdata) ; cede () ; } return 1 ; } # --------------------------------------------------------------------------- sub _run_tcp_server { my ($listen_port) = @_ ; if ($listen_port) { my $quit ; while (!$quit && !$exit) { logger (undef, "tcp server start listen on port $listen_port\n") ; my $tcpcv = AnyEvent::CondVar -> new ; my $guard ; eval { $guard = tcp_server '127.0.0.1', $listen_port, sub { my ($fh, $host, $port) = @_ ; async { eval { $fh = Coro::Handle::unblock ($fh) ; my $self = Perl::LanguageServer -> new ({out_fh => $fh, in_fh => $fh, log_prefix => 'DAx'}); $self -> logger ("connect from $host:$port\n") ; $self -> listen_port ($listen_port) ; $quit = $self -> mainloop () ; $self -> logger ("got quit signal\n") if ($quit) ; } ; logger (undef, $@) if ($@) ; if ($fh) { close ($fh) ; $fh = undef ; } if ($quit || $exit) { $tcpcv -> send ; IO::AIO::reinit () ; # stop AIO requests exit (1) ; } } ; } ; } ; if (!$@) { $tcpcv -> recv ; } else { $guard = undef ; logger (undef, $@) ; #$quit = 1 ; if (!$guard && ($@ =~ /Address already in use/)) { # stop other server tcp_connect '127.0.0.1', $listen_port, sub { my ($fh) = @_ ; syswrite ($fh, "Content-Length: 0\r\n\r\n") if ($fh) ; } ; } $@ = undef ; Coro::AnyEvent::sleep (2) ; IO::AIO::reinit () ; # stop AIO requests exit (1) ; # stop LS, vscode will restart it } } } } # --------------------------------------------------------------------------- sub run { my $listen_port ; my $no_stdio ; my $heartbeat ; while (my $opt = shift @ARGV) { if ($opt eq '--debug') { $debug1 = $debug2 = 1 ; } elsif ($opt eq '--log-level') { $debug1 = shift @ARGV ; $debug2 = $debug1 > 1?1:0 ; } elsif ($opt eq '--log-file') { $log_file = shift @ARGV ; } elsif ($opt eq '--port') { $listen_port = shift @ARGV ; } elsif ($opt eq '--nostdio') { $no_stdio = 1 ; } elsif ($opt eq '--heartbeat') { $heartbeat = 1 ; } elsif ($opt eq '--version') { $client_version = shift @ARGV ; } } $|= 1 ; my $cv = AnyEvent::CondVar -> new ; async { my $i = 0 ; while (1) { if ($heartbeat || $debug2) { logger (undef, "##### $i #####\n running: " . dump (\%running_reqs) . " coros: " . dump (\%running_coros), "\n") ; $i++ ; } Coro::AnyEvent::sleep (10) ; } } ; if (!$no_stdio) { async { my $self = Perl::LanguageServer -> new ({out_fh => 1, in_fh => 0}); $self -> listen_port ($listen_port) ; $self -> mainloop () ; $cv -> send ; } ; } async { _run_tcp_server ($listen_port) ; } ; $cv -> recv ; $exit = 1 ; } # --------------------------------------------------------------------------- sub parsews { my $class = shift ; my @args = @_ ; $|= 1 ; my $cv = AnyEvent::CondVar -> new ; async { my $self = Perl::LanguageServer -> new ; $workspace = Perl::LanguageServer::Workspace -> new ({ config => {} }) ; my %folders ; foreach my $path (@args) { $folders{$path} = $path ; } $workspace -> folders (\%folders) ; $workspace -> background_parser ($self) ; $cv -> send ; } ; $cv -> recv ; } # --------------------------------------------------------------------------- sub check_file { my $class = shift ; my @args = @_ ; $|= 1 ; my $cv = AnyEvent::CondVar -> new ; my $self = Perl::LanguageServer -> new ; $workspace = Perl::LanguageServer::Workspace -> new ({ config => {} }) ; async { my %folders ; foreach my $path (@args) { $folders{$path} = $path ; } $workspace -> folders (\%folders) ; $workspace -> background_checker ($self) ; $cv -> send ; } ; async { foreach my $path (@args) { my $text ; aio_load ($path, $text) ; $workspace -> check_perl_syntax ($workspace, $path, $text) ; } } ; $cv -> recv ; } 1 ; __END__ =head1 DOCUMENTATION Language Server and Debug Protocol Adapter for Perl =head2 Features =over =item * Language Server =over =item * Syntax checking =item * Symbols in file =item * Symbols in workspace/directory =item * Goto Definition =item * Find References =item * Call Signatures =item * Supports multiple workspace folders =item * Document and selection formatting via perltidy =item * Run on remote system via ssh =item * Run inside docker container =item * Run inside kubernetes =back =item * Debugger =over =item * Run, pause, step, next, return =item * Support for coro threads =item * Breakpoints =item * Conditional breakpoints =item * Breakpoints can be set while program runs and for modules not yet loaded =item * Variable view, can switch to every stack frame or coro thread =item * Set variable =item * Watch variable =item * Tooltips with variable values =item * Evaluate perl code in debuggee, in context of every stack frame of coro thread =item * Automatically reload changed Perl modules while debugging =item * Debug multiple perl programs at once =item * Run on remote system via ssh =item * Run inside docker container =item * Run inside kubernetes =back =back =head2 Requirements You need to install the perl module Perl::LanguageServer to make this extension work, e.g. run C on your target system. Please make sure to always run the newest version of Perl::LanguageServer as well. NOTE: Perl::LanguageServer depend on AnyEvent::AIO and Coro. There is a warning that this might not work with newer Perls. It works fine for Perl::LanguageServer. So just confirm the warning and install it. Perl::LanguageServer depends on other Perl modules. It is a good idea to install most of then with your linux package manager. e.g. on Debian/Ubuntu run: sudo apt install libanyevent-perl libclass-refresh-perl libcompiler-lexer-perl \ libdata-dump-perl libio-aio-perl libjson-perl libmoose-perl libpadwalker-perl \ libscalar-list-utils-perl libcoro-perl sudo cpan Perl::LanguageServer e.g. on Centos 7 run: sudo yum install perl-App-cpanminus perl-AnyEvent-AIO perl-Coro sudo cpanm Class::Refresh sudo cpanm Compiler::Lexer sudo cpanm Hash::SafeKeys sudo cpanm Perl::LanguageServer In case any of the above packages are not available for your os version, just leave them out. The cpan command will install missing dependencies. In case the test fails, when running cpan C, you should try to run C. =head2 Extension Settings This extension contributes the following settings: =over =item * C: enable/disable this extension =item * C: ip address of remote system =item * C: optional, port for ssh to remote system =item * C: user for ssh login =item * C: defaults to ssh on unix and plink on windows =item * C: path of the workspace root on remote system =item * C: defaults to perl =item * C: additional arguments passed to the perl interpreter that starts the LanguageServer =item * C: if true, use taint mode for syntax check =item * C: optional arguments for ssh =item * C: mapping of local to remote paths =item * C: array with paths to add to perl library path. This setting is used by the syntax checker and for the debuggee and also for the LanguageServer itself. =item * C: array for filtering perl file, defaults to [I<.pm,>.pl] =item * C: directories to ignore, defaults to [.vscode, .git, .svn] =item * C: port to use for connection between vscode and debug adapter inside Perl::LanguageServer. =item * C: if debugAdapterPort is in use try ports from debugAdapterPort to debugAdapterPort + debugAdapterPortRange. Default 100. =item * C: if true, show also local variables in symbol view =item * C: Log level 0-2. =item * C: If set, log output is written to the given logfile, instead of displaying it in the vscode output pane. Log output is always appended. Only use during debugging of LanguageServer itself. =item * C: If true, the LanguageServer will not cache the result of parsing source files on disk, so it can be used within readonly directories =item * C: If set Perl::LanguageServer can run inside a container. Options are: 'docker', 'docker-compose', 'kubectl' =item * C: arguments for containerCmd. Varies depending on containerCmd. =item * C: To start a new container, set to 'run', to execute inside an existing container set to 'exec'. Note: kubectl only supports 'exec' =item * C: Image to start or container to exec inside or pod to use =back =head2 Debugger Settings for launch.json =over =item * C: needs to be C =item * C: only C is supported (this is a restriction of perl itself) =item * C: name of this debug configuration =item * C: path to perl program to start =item * C: if true, program will stop on entry =item * C: optional, array or string with arguments for perl program =item * C: optional, object with environment settings =item * C: optional, change working directory before launching the debuggee =item * C: if true, automatically reload changed Perl modules while debugging =item * C: optional, if set run debug process with sudo -u \. =item * C: optional, if true run debug process with -T (taint mode). =item * C: If set debugger runs inside a container. Options are: 'docker', 'docker-compose', 'podman', 'kubectl' =item * C: arguments for containerCmd. Varies depending on containerCmd. =item * C: To start a new container, set to 'run', to debug inside an existing container set to 'exec'. Note: kubectl only supports 'exec' =item * C: Image to start or container to exec inside or pod to use =item * C: mapping of local to remote paths for this debug session (overwrites global C) =back =head2 Remote syntax check & debugging If you developing on a remote machine, you can instruct the Perl::LanguageServer to run on that remote machine, so the correct modules etc. are available for syntax check and debugger is started on the remote machine. To do so set sshAddr and sshUser, preferably in your workspace configuration. Example: "sshAddr": "10.11.12.13", "sshUser": "root" Also set sshWorkspaceRoot, so the local workspace path can be mapped to the remote one. Example: if your local path is \10.11.12.13\share\path\to\ws and on the remote machine you have /path/to/ws "sshWorkspaceRoot": "/path/to/ws" The other possibility is to provide a pathMap. This allows one to having multiple mappings. Examples: "perl.pathMap": [ ["remote uri", "local uri"], ["remote uri", "local uri"] ] "perl.pathMap": [ [ "file:///", "file:///home/systems/mountpoint/" ] ] =head2 Syntax check & debugging inside a container You can run the LanguageServer and/or debugger inside a container by setting C and C. There are more container options, see above. .vscode/settings.json { "perl": { "enable": true, "containerCmd": "docker", "containerName": "perl_container", } } This will start the whole Perl::LanguageServer inside the container. This is espacally helpfull to make syntax check working, if there is a different setup inside and outside the container. In this case you need to tell the Perl::LanguageServer how to map local paths to paths inside the container. This is done by setting C (see above). Example: "perl.pathMap": [ [ "file:///path/inside/the/container", "file:///local/path/outside/the/container" ] ] It's also possible to run the LanguageServer outside the container and only the debugger inside the container. This is especially helpfull, when the container is not always running, while you are editing. To make only the debugger running inside the container, put C, C and C in your C. You can have different setting for each debug session. Normaly the arguments for the C are automatically build. In case you want to use an unsupported C you need to specifiy apropriate C. =head2 FAQ =head3 Working directory is not defined It is not defined what the current working directory is at the start of a perl program. So Perl::LanguageServer makes no assumptions about it. To solve the problem you can set the directory via cwd configuration parameter in launch.json for debugging. =head3 Module not found when debugging or during syntax check If you reference a module with a relative path or if you assume that the current working directory is part of the Perl search path, it will not work. Instead set the perl include path to a fixed absolute path. In your settings.json do something like: "perl.perlInc": [ "/path/a/lib", "/path/b/lib", "/path/c/lib", ], Include path works for syntax check and inside of debugger. C should be an absolute path. =head3 AnyEvent, Coro Warning during install You need to install the AnyEvent::IO and Coro. Just ignore the warning that it might not work. For Perl::LanguageServer it works fine. =head3 'richterger.perl' failed: options.port should be >= 0 and < 65536 Change port setting from string to integer =head3 Error "Can't locate MODULE_NAME" Please make sure the path to the module is in C setting and use absolute path names in the perlInc settings or make sure you are running in the expected directory by setting the C setting in the lauch.json. =head3 ERROR: Unknown perlmethod IsetTraceNotification This is not an issue, that just means that not all features of the debugging protocol are implemented. Also it says ERROR, it's just a warning and you can safely ignore it. =head3 The debugger sometimes stops at random places Upgrade to Version 2.4.0 =head3 Message about Perl::LanguageServer has crashed 5 times This is a problem when more than one instance of Perl::LanguageServer is running. Upgrade to Version 2.4.0 solves this problem. =head3 The program I want to debug needs some input via stdin You can read stdin from a file during debugging. To do so add the following parameter to your C: C<< "args": [ "E", "/path/to/stdin.txt" ] >> e.g. C<< { "type": "perl", "request": "launch", "name": "Perl-Debug", "program": "${workspaceFolder}/${relativeFile}", "stopOnEntry": true, "reloadModules": true, "env": { "REQUEST_METHOD": "POST", "CONTENT_TYPE": "application/x-www-form-urlencoded", "CONTENT_LENGTH": 34 } "args": [ "E", "/path/to/stdin.txt" ] } >> =head3 Carton support If you are using LL to manage dependencies, add the full path to the Carton C dir to your workspace settings file at C<.vscode/settings.json>. For example: =head4 Linux { "perl.perlInc": ["/home/myusername/projects/myprojectname/local/lib/perl5"] } =head4 Mac { "perl.perlInc": ["/Users/myusername/projects/myprojectname/local/lib/perl5"] } =head2 Known Issues Does not yet work on windows, due to issues with reading from stdin. I wasn't able to find a reliable way to do a non-blocking read from stdin on windows. I would be happy, if anyone knows how to do this in Perl. Anyway, Perl::LanguageServer runs without problems inside of Windows Subsystem for Linux (WSL). =head2 Release Notes see CHANGELOG.md =head2 More Info =over =item * Presentation at German Perl Workshop 2020: =back https://github.com/richterger/Perl-LanguageServer/blob/master/docs/Perl-LanguageServer%20und%20Debugger%20f%C3%BCr%20Visual%20Studio%20Code%20u.a.%20Editoren%20-%20Perl%20Workshop%202020.pdf =over =item * Github: https://github.com/richterger/Perl-LanguageServer =item * MetaCPAN: https://metacpan.org/release/Perl-LanguageServer =back For reporting bugs please use GitHub issues. =head2 References This is a Language Server and Debug Protocol Adapter for Perl It implements the Language Server Protocol which provides syntax-checking, symbol search, etc. Perl to various editors, for example Visual Studio Code or Atom. https://microsoft.github.io/language-server-protocol/specification It also implements the Debug Adapter Protocol, which allows debugging with various editors/includes https://microsoft.github.io/debug-adapter-protocol/overview To use both with Visual Studio Code, install the extension "perl" https://marketplace.visualstudio.com/items?itemName=richterger.perl Any comments and patches are welcome. =head2 LICENSE AND COPYRIGHT Copyright 2018-2022 Gerald Richter. This program is free software; you can redistribute it and/or modify it under the terms of the Artistic License (2.0). You may obtain a copy of the full license at: LL Any use, modification, and distribution of the Standard or Modified Versions is governed by this Artistic License. By using, modifying or distributing the Package, you accept this license. Do not use, modify, or distribute the Package, if you do not accept this license. If your Modified Version has been derived from a Modified Version made by someone other than you, you are nevertheless required to ensure that your Modified Version complies with the requirements of this license. This license does not grant you the right to use any trademark, service mark, tradename, or logo of the Copyright Holder. This license includes the non-exclusive, worldwide, free-of-charge patent license to make, have made, use, offer to sell, sell, import and otherwise transfer the Package with respect to any patent claims licensable by the Copyright Holder that are necessarily infringed by the Package. If you institute patent litigation (including a cross-claim or counterclaim) against any party alleging that the Package constitutes direct or contributory patent infringement, then this Artistic License to you shall terminate on the date that such litigation is filed. Disclaimer of Warranty: THE PACKAGE IS PROVIDED BY THE COPYRIGHT HOLDER AND CONTRIBUTORS "AS IS' AND WITHOUT ANY EXPRESS OR IMPLIED WARRANTIES. THE IMPLIED WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE, OR NON-INFRINGEMENT ARE DISCLAIMED TO THE EXTENT PERMITTED BY YOUR LOCAL LAW. UNLESS REQUIRED BY LAW, NO COPYRIGHT HOLDER OR CONTRIBUTOR WILL BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING IN ANY WAY OUT OF THE USE OF THE PACKAGE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. =head1 Change Log =head2 2.6.2 C<2023-12-23> =over =item * avoid given/when/smartmatch because these features are deprecated in perl 5.38 (#199) [real-dam] =back =head2 2.6.1 C<2023-07-26> =over =item * Fix: Formatting with perltidy was broken in 2.6.0 =back =head2 2.6.0 C<2023-07-23> =over =item * Add debug setting for running as different user. See sudoUser setting. (#174) [wielandp] =item * Allow to use a string for debuggee arguments. (#149, #173) [wielandp] =item * Add stdin redirection (#166) [wielandp] =item * Add link to issues to META files (#168) [szabgab/issues] =item * Add support for podman =item * Add support for run Perl::LanguageServer outside, but debugger inside a container =item * Add setting useTaintForSyntaxCheck. If true, use taint mode for syntax check (#172) [wielandp] =item * Add setting useTaintForDebug. If true, use taint mode inside debugger (#181) [wielandp] =item * Add debug adapter request C, which allows to display source of eval or file that are not available to vscode (#180) [wielandp] =item * Fix: Spelling (#170, #171) [pkg-perl-tools] =item * Fix: Convert charset encoding of debugger output according to current locale (#167) [wielandp] =item * Fix: Fix diagnostic notifications override on clients (based on #185) [bmeneg] =back =head2 2.5.0 C<2023-02-05> =over =item * Set minimal Perl version to 5.16 (#91) =item * Per default environment from vscode will be passed to debuggee, syntax check and perltidy. =item * Add configuration C to not pass environment variables. =item * Support for C and C settings via LanguageServer protocol and not only via command line options (#97) [schellj] =item * Fix: "No DB::DB routine defined" (#91) [peterdragon] =item * Fix: Typos and spelling in README (#159) [dseynhae] =item * Fix: Update call to gensym(), to fix 'strict subs' error (#164) [KohaAloha] =item * Convert identention from tabs to spaces and remove trailing whitespaces =back =head2 2.4.0 C<2022-11-18> =over =item * Choose a different port for debugAdapterPort if it is already in use. This avoids trouble with starting C if another instance of C is running on the same machine (thanks to hakonhagland) =item * Add configuration C, for choosing range of port for dynamic port assignment =item * Add support for using LanguageServer and debugger inside a Container. Currently docker containers und containers running inside kubernetes are supported. =item * When starting debugger session and C is false, do not switch to sourefile where debugger would stop, when C is true. =item * Added some FAQs in README =item * Fix: Debugger stopps at random locations =item * Fix: debugAdapterPort is now numeric =item * Fix: debugging loop with each statement (#107) =item * Fix: display of arrays in variables pane on mac (#120) =item * Fix: encoding for C (#127) =item * Fix: return error if C fails, so text is not removed by failing formatting request (#87) =item * Fix: FindBin does not work when checking syntax (#16) =back =head2 2.3.0 C<2021-09-26> =over =item * Arguments section in Variable lists now C<@ARGV> and C<@_> during debugging (#105) =item * C<@_> is now correctly evaluated inside of debugger console =item * C<$#foo> is now correctly evaluated inside of debugger console =item * Default debug configuration is now automatically provided without the need to create a C first (#103) =item * Add Option C to specify location of cache dir (#113) =item * Fix: Debugger outputted invalid thread reference causes "no such coroutine" message, so watchs and code from the debug console is not expanded properly =item * Fix: LanguageServer hangs when multiple request send at once from VSCode to LanguageServer =item * Fix: cwd parameter for debugger in launch.json had no effect (#99) =item * Fix: Correctly handle paths with drive letters on windows =item * Fix: sshArgs parameter was not declared as array (#109) =item * Disable syntax check on windows, because it blocks the whole process when running on windows, until handling of child's processes is fixed =item * Fixed spelling (#86,#96,#101) [chrstphrchvz,davorg,aluaces] =back =head2 2.2.0 C<2021-02-21> =over =item * Parser now supports Moose method modifieres before, after and around, so they can be used in symbol view and within reference search =item * Support Format Document and Format Selection via perltidy =item * Add logFile config option =item * Add perlArgs config option to pass options to Perl interpreter. Add some documentation for config options. =item * Add disableCache config option to make LanguageServer usable with readonly directories. =item * updated dependencies package.json & package-lock.json =item * Fix deep recursion in SymbolView/Parser which was caused by function prototypes. Solves also #65 =item * Fix duplicate req id's that caused cleanup of still running threads which in turn caused the LanguageServer to hang =item * Prevent dereferencing an undefined value (#63) [Heiko Jansen] =item * Fix datatype of cwd config options (#47) =item * Use perlInc setting also for LanguageServer itself (based only pull request #54 from ALANVF) =item * Catch Exceptions during display of variables inside debugger =item * Fix detecting duplicate LanguageServer processes =item * Fix spelling in documentation (#56) [Christopher Chavez] =item * Remove notice about Compiler::Lexer 0.22 bugs (#55) [Christopher Chavez] =item * README: Typo and grammar fixes. Add Carton lib path instructions. (#40) [szTheory] =item * README: Markdown code block formatting (#42) [szTheory] =item * Makefile.PL: add META_MERGE with GitHub info (#32) [Christopher Chavez] =item * search.cpan.org retired, replace with metacpan.org (#31) [Christopher Chavez] =back =head2 2.1.0 C<2020-06-27> =over =item * Improve Symbol Parser (fix parsing of anonymous subs) =item * showLocalSymbols =item * function names in breadcrump =item * Signature Help for function/method arguments =item * Add Presentation on Perl Workshop 2020 to repos =item * Remove Compiler::Lexer from distribution since version is available on CPAN =item * Make stdout unbuffered while debugging =item * Make debugger use perlInc setting =item * Fix fileFilter setting =item * Sort Arrays numerically in variables view of debugger =item * Use rootUri if workspaceFolders not given =item * Fix env config setting =item * Recongnice changes in config of perlCmd =back =head2 2.0.2 C<2020-01-22> =over =item * Plugin: Fix command line parameters for plink =item * Perl::LanguageServer: Fix handling of multiple parallel request, improve symlink handling, add support for UNC paths in path mapping, improve logging for logLevel = 1 =back =head2 2.0.1 C<2020-01-14> Added support for reloading Perl module while debugging, make log level configurable, make sure tooltips don't call functions =head2 2.0.0 C<2020-01-01> Added Perl debugger =head2 0.9.0 C<2019-05-03> Fix issues in the Perl part, make sure to update Perl::LanguageServer from cpan =head2 0.0.3 C<2018-09-08> Fix issue with not reading enough from stdin, which caused LanguageServer to hang sometimes =head2 0.0.2 C<2018-07-21> Fix quitting issue when starting Perl::LanguageServer, more fixes are in the Perl part =head2 0.0.1 C<2018-07-13> Initial Version Perl-LanguageServer-2.6.2/lib/Perl/LanguageServer/0000755000000000000000000000000014541562103020414 5ustar rootrootPerl-LanguageServer-2.6.2/lib/Perl/LanguageServer/Methods/0000755000000000000000000000000014541562103022017 5ustar rootrootPerl-LanguageServer-2.6.2/lib/Perl/LanguageServer/Methods/textDocument.pm0000644000000000000000000003346214460121444025047 0ustar rootrootpackage Perl::LanguageServer::Methods::textDocument ; use Moose::Role ; use Coro ; use Coro::AIO ; use Data::Dump qw{pp} ; use AnyEvent::Util ; use Encode; no warnings 'uninitialized' ; # --------------------------------------------------------------------------- sub get_symbol_from_doc { my ($self, $workspace, $uri, $pos) = @_ ; my $files = $workspace -> files ; my $text = $files -> {$uri}{text} ; my $line = $pos -> {line} ; my $char = $pos -> {character} ; $text =~ /(?:.*?\n){$line}(.*?)\n/ ; my $data = $1 ; my $datapos = $-[1] ; $self -> logger ("line $line: <$data>\n") if ($Perl::LanguageServer::debug2) ; while ($data =~ /([a-zA-Z0-9_\$\%\@]+)/g) { my $pos = pos ($data) ; my $len = length ($1) ; $self -> logger ("word: <$1> pos: $pos len: $len\n") if ($Perl::LanguageServer::debug2) ; if ($char <= $pos && $char >= $pos - $len) { $self -> logger ("ok\n") if ($Perl::LanguageServer::debug2) ; return wantarray?($1, $datapos + $-[1]):$1 ; } } return ; } # --------------------------------------------------------------------------- sub get_symbol_before_left_parenthesis { my ($self, $workspace, $uri, $pos) = @_ ; my $files = $workspace -> files ; my $text = $files -> {$uri}{text} ; my $line = $pos -> {line} ; my $char = $pos -> {character} - 1 ; my $cnt = 1 ; my $i ; my $endpos ; my @symbol ; my $symbolpos ; while ($line > 0) { $text =~ /(?:.*?\n){$line}(.*?)(?:\n|$)/ ; my $data = $1 ; $endpos //= $-[1] + $char ; my $datapos = $-[1] ; $self -> logger ("line $line: <$data>\n") if ($Perl::LanguageServer::debug2) ; $char = length ($data) - 1 if (!defined ($char)) ; for ($i = $char; $i >= 0; $i--) { my $c = substr ($data, $i, 1) ; if ($cnt == 0) { if ($c =~ /\w/) { push @symbol, $c ; $symbolpos = $datapos + $i ; next ; } elsif (@symbol) { last ; } elsif ($c eq ';') { return ; } @symbol = () ; } if ($c eq '(') { $cnt-- } elsif ($c eq ')') { $cnt++ } elsif ($c eq ';') { return ; } } last if (@symbol) ; $line-- ; $char = undef ; } my $method ; for ($i = $symbolpos - 1 ; $i > 0; $i--) { my $c = substr ($text, $i, 1) ; if ($c eq '>' && substr ($text, $i - 1, 1) eq '-') { $method = 1 ; last ; } last if ($c !~ /\s/) ; } my $symbol = join ('', reverse @symbol) ; return ($symbol, substr ($text, $symbolpos, $endpos - $symbolpos + 1), $symbolpos, $endpos, $method) ; } # --------------------------------------------------------------------------- sub _rpcnot_didOpen { my ($self, $workspace, $req) = @_ ; my $files = $workspace -> files ; my $uri = $req -> params -> {textDocument}{uri} ; my $text = $req -> params -> {textDocument}{text} ; my $vers = $req -> params -> {textDocument}{version} ; $files -> {$uri}{text} = $text ; $files -> {$uri}{version} = $vers ; delete $files -> {$uri}{vars} ; delete $files -> {$uri}{messages} if ($files -> {$uri}{messages_version} < $vers); $workspace -> check_perl_syntax ($workspace, $uri, $text) ; return ; } # --------------------------------------------------------------------------- sub _rpcnot_didChange { my ($self, $workspace, $req) = @_ ; my $files = $workspace -> files ; my $uri = $req -> params -> {textDocument}{uri} ; my $text = $req -> params -> {contentChanges}[0]{text} ; my $vers = $req -> params -> {textDocument}{version} ; $files -> {$uri}{text} = $text ; $files -> {$uri}{version} = $vers ; delete $files -> {$uri}{vars} ; delete $files -> {$uri}{messages} if ($files -> {$uri}{messages_version} < $vers); $workspace -> check_perl_syntax ($workspace, $uri, $text) ; return ; } # --------------------------------------------------------------------------- sub _rpcnot_didClose { my ($self, $workspace, $req) = @_ ; my $files = $workspace -> files ; my $uri = $req -> params -> {textDocument}{uri} ; delete $files -> {$uri}{text} ; delete $files -> {$uri}{version} ; delete $files -> {$uri}{vars} ; delete $files -> {$uri}{messages} ; return ; } # --------------------------------------------------------------------------- sub _rpcnot_didSave { my ($self, $workspace, $req) = @_ ; my $uri = $req -> params -> {textDocument}{uri} ; $workspace -> parser_channel -> put (['save', $uri]) ; } # --------------------------------------------------------------------------- sub _filter_children { my ($self, $children, $show_local_vars) = @_ ; my @vars ; foreach my $v (@$children) { if (exists $v -> {definition} && (!exists $v -> {localvar} || $show_local_vars)) { if (exists $v -> {children}) { push @vars, { %$v, children => $self -> _filter_children ($v -> {children})} ; } else { push @vars, $v ; } } } return \@vars ; } # --------------------------------------------------------------------------- sub _rpcreq_documentSymbol { my ($self, $workspace, $req) = @_ ; my $files = $workspace -> files ; my $uri = $req -> params -> {textDocument}{uri} ; my $text = $files -> {$uri}{text} ; return [] if (!$text) ; my $show_local_vars = $workspace -> show_local_vars ; my $vars = $files -> {$uri}{vars} ; if (!$vars) { $vars = $workspace -> parse_perl_source ($uri, $text) ; $files -> {$uri}{vars} = $vars ; } my @vars ; foreach my $v (@$vars) { if (exists $v -> {definition} && (!exists $v -> {localvar} || $show_local_vars)) { if (exists $v -> {children}) { push @vars, { %$v, children => $self -> _filter_children ($v -> {children})} ; } else { push @vars, $v ; } } } return \@vars ; } # --------------------------------------------------------------------------- sub _get_symbol { my ($self, $workspace, $req, $symbol, $name, $uri, $def_only, $vars) = @_ ; if (exists $symbol -> {children}) { foreach my $s (@{$symbol -> {children}}) { $self -> _get_symbol ($workspace, $req, $s, $name, $uri, $def_only, $vars) ; last if (@$vars > 500) ; } } return if ($symbol -> {name} ne $name) ; #print STDERR "name=$name symbols = ", pp ($symbol), "\n" ; return if ($def_only && !exists $symbol -> {definition}) ; my $line = $symbol -> {line} + 0 ; push @$vars, { uri => $uri, range => { start => { line => $line, character => 0 }, end => { line => $line, character => 0 }}} ; } # --------------------------------------------------------------------------- sub _get_symbols { my ($self, $workspace, $req, $def_only) = @_ ; my $pos = $req -> params -> {position} ; my $uri = $req -> params -> {textDocument}{uri} ; my $name = $self -> get_symbol_from_doc ($workspace, $uri, $pos) ; my $symbols = $workspace -> symbols ; #print STDERR "name=$name symbols = ", pp ($symbols), "\n" ; my $line ; my @vars ; if ($name) { foreach my $uri (keys %$symbols) { foreach my $symbol (@{$symbols->{$uri}}) { $self -> _get_symbol ($workspace, $req, $symbol, $name, $uri, $def_only, \@vars) ; last if (@vars > 500) ; } } } return \@vars ; } # --------------------------------------------------------------------------- sub _rpcreq_definition { my ($self, $workspace, $req) = @_ ; return $self -> _get_symbols ($workspace, $req, 1) ; } # --------------------------------------------------------------------------- sub _rpcreq_references { my ($self, $workspace, $req) = @_ ; return $self -> _get_symbols ($workspace, $req, 0) ; } # --------------------------------------------------------------------------- sub _rpcreq_signatureHelp { my ($self, $workspace, $req) = @_ ; my $pos = $req -> params -> {position} ; my $uri = $req -> params -> {textDocument}{uri} ; $self -> logger (pp($req -> params)) ; my ($name, $expr, $symbolpos, $endpos, $method) = $self -> get_symbol_before_left_parenthesis ($workspace, $uri, $pos) ; return { signatures => [] } if (!$name) ; my $argnum = 0 ; while ($expr =~ /,/g) { $argnum++ ; } $argnum += ($method?1:0) ; my $symbols = $workspace -> symbols ; my $line ; my @vars ; foreach my $uri (keys %$symbols) { foreach my $symbol (@{$symbols->{$uri}}) { next if ($symbol -> {name} ne $name) ; next if (!exists $symbol -> {definition}) ; next if (!exists $symbol -> {signature}) ; push @vars, $symbol -> {signature} ; last if (@vars > 200) ; } } $self -> logger (pp(\@vars)) if ($Perl::LanguageServer::debug2) ; my $signum = 0 ; my $context = $req -> params -> {context} ; if ($context) { $signum = $context -> {activeSignatureHelp}{activeSignature} // 0 ; } return { signatures => \@vars, activeParameter => $argnum + 0, activeSignature => $signum + 0 } ; } # --------------------------------------------------------------------------- sub _rpcreq_selectionRange { my ($self, $workspace, $req) = @_ ; my $pos = $req -> params -> {position} ; my $uri = $req -> params -> {textDocument}{uri} ; #$self -> logger (pp($req -> params)) ; my ($symbol, $offset) = $self -> get_symbol_from_doc ($workspace, $uri, $pos) ; $self -> logger ("sym = $symbol, $offset") ; return {} ; } # --------------------------------------------------------------------------- sub _rpcreq_rangeFormatting { my ($self, $workspace, $req) = @_ ; my $uri = $req -> params -> {textDocument}{uri} ; my $range = $req -> params -> {range} ; #$workspace -> parser_channel -> put (['save', $uri]) ; $self -> logger (pp($req -> params)) ; my $fn = $uri ; $fn =~ s/^file:\/\/// ; $fn = $workspace -> file_client2server ($fn) ; #FormattingOptions # Size of a tab in spaces. #tabSize: uinteger; # Prefer spaces over tabs. #insertSpaces: boolean; # Trim trailing whitespace on a line. #trimTrailingWhitespace?: boolean; # Insert a newline character at the end of the file if one does not exist. # insertFinalNewline?: boolean; #trimFinalNewlines?: boolean; my $ret ; my $out ; my $errout ; my $files = $workspace -> files ; my $text = $files -> {$uri}{text} ; my $start = $range -> {start}{line} ; my $end = $range -> {end}{line} ; my $char = $range -> {end}{character} ; $end-- if ($end > 0 && $char == 0) ; my $lines = $end - $start + 1 ; $text =~ /(?:.*?\n){$start}((?:.*?\n){$lines})/ ; my $range_text = $1 ; $range_text =~ s/\n$// ; if ($range_text eq '') { $text =~ /(?:.*?\n){$start}(.+)/s ; $range_text = $1 ; $range_text =~ s/\n$// ; } $self -> logger ('perltidy text: <' . $range_text . ">\n") if ($Perl::LanguageServer::debug2) ; return [] if ($range_text eq '') ; my $lang = $ENV{LANG} ; my $encoding = 'UTF-8' ; $encoding = $1 if ($lang =~ /\.(.+)/) ; $range_text = Encode::encode($encoding, $range_text) ; $self -> logger ("start perltidy $uri from line $start to $end\n") if ($Perl::LanguageServer::debug1) ; if ($^O =~ /Win/) { ($ret, $out, $errout) = $workspace -> run_open3 ($range_text, []) ; } else { $ret = run_cmd (['perltidy', '-st', '-se'], "<", \$range_text, ">", \$out, "2>", \$errout) -> recv ; } my $rc = $ret >> 8 ; $self -> logger ("perltidy rc=$rc errout=$errout\n") if ($Perl::LanguageServer::debug1) ; my @messages ; if ($rc != 0) { my $line ; my @lines = split /\n/, $errout ; my $lineno = 0 ; my $filename ; my $msg ; my $severity = 2 ; foreach $line (@lines) { next if ($line !~ /^(.+?):(\d+):(.+)/) ; $filename = $1 eq ''?$fn:$1 ; $lineno = $2 ; $msg = $3 ; push @messages, [$filename, $lineno, $severity, $msg] if ($lineno && $msg) ; } } $workspace -> add_diagnostic_messages ($self, $uri, 'perltidy', \@messages, $files -> {$uri}{version} + 1) ; die "perltidy failed with exit code $rc" if ($rc != 0 && $out eq '') ; # make sure range is numeric $range -> {start}{line} += 0 ; $range -> {start}{character} = 0 ; $range -> {end}{line} += $range -> {end}{character} > 0?1:0 ; $range -> {end}{character} = 0 ; return [ { newText => Encode::decode($encoding, $out), range => $range } ] ; } # --------------------------------------------------------------------------- 1 ; Perl-LanguageServer-2.6.2/lib/Perl/LanguageServer/Methods/DebugAdapterInterface.pm0000644000000000000000000001535414370012022026523 0ustar rootrootpackage 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 ; Perl-LanguageServer-2.6.2/lib/Perl/LanguageServer/Methods/workspace.pm0000644000000000000000000001274514456571617024403 0ustar rootroot package Perl::LanguageServer::Methods::workspace ; use strict ; use Moose::Role ; use Coro ; use Data::Dump qw{dump} ; # --------------------------------------------------------------------------- sub _rpcnot_didChangeConfiguration { my ($self, $workspace, $req) = @_ ; my $log_file = $req -> params -> {settings}{perl}{logFile} ; if ($log_file) { $Perl::LanguageServer::log_file = $log_file; $self -> logger ("log_file = $log_file\n") ; } $self -> logger ("perl = ", dump ($req -> params -> {settings}{perl}), "\n") ; my $log_level = $req -> params -> {settings}{perl}{logLevel} ; if (defined $log_level && length $log_level) { my $int_log_level = 0+$log_level; if ($int_log_level >= 0 && $int_log_level <= 2) { $Perl::LanguageServer::debug1 = $int_log_level; $Perl::LanguageServer::debug2 = $int_log_level > 1?1:0; $self -> logger ("log_level = $int_log_level\n") ; } else { $self -> logger ("log_level: unexpected value ($log_level)\n") ; } } my $uri = $req -> params -> {settings}{perl}{sshWorkspaceRoot} ; if ($uri) { $uri =~ s/\\/\//g ; $uri = 'file://' . $uri if ($uri !~ /^file:/) ; $workspace -> path_map ([[$uri, $workspace -> config -> {rootUri}]]) ; } my $map = $req -> params -> {settings}{perl}{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 ; } $workspace -> path_map ($map) ; } $self -> logger ("path_map = ", dump ( $workspace -> path_map), "\n") ; my $inc = $req -> params -> {settings}{perl}{perlInc} ; if ($inc) { $inc = [$inc] if (!ref $inc) ; $workspace -> perlinc ($inc) ; } $self -> logger ("perlinc = ", dump ( $workspace -> perlinc), "\n") ; $workspace -> use_taint_for_syntax_check ($req -> params -> {settings}{perl}{useTaintForSyntaxCheck}) ; $self -> logger ("use_taint_for_syntax_check = ", dump ( $workspace -> use_taint_for_syntax_check), "\n") ; my $filter = $req -> params -> {settings}{perl}{fileFilter} ; if ($filter) { $filter = [$filter] if (!ref $filter) ; $workspace -> file_filter_regex ('(?:' . join ('|', map { quotemeta($_) } @$filter ) . ')$') ; } $self -> logger ("file_filter_regex = ", dump ( $workspace -> file_filter_regex), "\n") ; my $dirs = $req -> params -> {settings}{perl}{ignoreDirs} ; if ($dirs) { $dirs = [$dirs] if (!ref $dirs) ; $workspace -> ignore_dir ({ map { ( $_ => 1 ) } @$dirs }) ; } $self -> logger ("ignore_dir = ", dump ( $workspace -> ignore_dir), "\n") ; if (!exists ($workspace -> config -> {workspaceFolders}) || @{$workspace -> config -> {workspaceFolders} // []} == 0) { $workspace -> config -> {workspaceFolders} = [{ uri => $workspace -> config -> {rootUri} }] ; } $workspace -> set_workspace_folders ($workspace -> config -> {workspaceFolders} ) ; $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 { $workspace -> background_parser ($self) ; } ; async { $workspace -> background_checker ($self) ; } ; return ; } # --------------------------------------------------------------------------- sub _rpcnot_didChangeWorkspaceFolders { my ($self, $workspace, $req) = @_ ; my $added = $req -> params -> {event}{added} ; if ($added) { $workspace -> set_workspace_folders ($added) ; } my $removed = $req -> params -> {event}{removed} ; if ($removed) { foreach my $folder (@$removed) { my $uri = $folder -> {uri} ; #TODO } } async { $workspace -> background_parser ($self) ; } ; } # --------------------------------------------------------------------------- sub _rpcreq_symbol { my ($self, $workspace, $req) = @_ ; my $query = $req -> params -> {query} || '.' ; my $symbols = $workspace -> symbols ; #$self -> logger ("symbols = ", dump ($symbols), "\n") ; my $line ; my @vars ; foreach my $uri (keys %$symbols) { foreach my $symbol (@{$symbols->{$uri}}) { next if ($symbol -> {name} !~ /$query/) ; next if (!exists $symbol -> {definition}) ; $line = $symbol -> {line} ; push @vars, { %$symbol, location => { uri => $uri, range => { start => { line => $line, character => 0 }, end => { line => $line, character => 0 }}} } ; last if (@vars > 200) ; } } return \@vars ; } # --------------------------------------------------------------------------- 1 ; Perl-LanguageServer-2.6.2/lib/Perl/LanguageServer/Methods/DebugAdapter.pm0000644000000000000000000006023114456571617024725 0ustar rootrootpackage Perl::LanguageServer::Methods::DebugAdapter ; use Moose::Role ; use Coro ; use Coro::AIO ; use Data::Dump qw{dump pp} ; use Perl::LanguageServer::DevTool ; use Perl::LanguageServer::DebuggerProcess ; no warnings 'uninitialized' ; our %debug_adapters ; # --------------------------------------------------------------------------- has 'debugger_process' => ( isa => 'Perl::LanguageServer::DebuggerProcess', is => 'rw' ) ; has 'debug_adapter_interface' => ( isa => 'Perl::LanguageServer', is => 'rw', weak_ref => 1, ) ; has 'ref2id' => ( isa => 'HashRef', is => 'rw', default => sub { {} }, ) ; has 'id2ref' => ( isa => 'HashRef', is => 'rw', default => sub { {} }, ) ; has 'refcnt' => ( isa => 'Int', is => 'rw', default => 1, ) ; has 'running' => ( isa => 'Int', is => 'rw', default => 0, ) ; has 'in_temp_break' => ( isa => 'Int', is => 'rw', default => 0, ) ; # --------------------------------------------------------------------------- sub getid { my ($self, $parentid, $ref, $param) = @_ ; my $refs = $self -> ref2id ; my $ndx = $parentid . ':' . $ref ; return $refs -> {$ndx} + 0 if (exists $refs -> {$ndx}) ; my $refcnt = $self -> refcnt ; $self -> id2ref -> {$refcnt} = { ref => $ref, ($param?%$param:()) } ; $refs -> {$ndx} = $refcnt+0 ; $refcnt++ ; return $self -> refcnt ($refcnt) - 1 ; # make sure there is no string value, so encode json encodes it as number } # --------------------------------------------------------------------------- sub clear_non_thread_ids { my ($self) = @_ ; my $refs = $self -> ref2id ; my $id2refs = $self -> id2ref ; my $id ; foreach (keys %$refs) { if (/^0:/) { $id = delete $refs -> {$_} ; delete $id2refs -> {$id} ; } } } # --------------------------------------------------------------------------- sub send_event { my ($self, $event, $body) = @_ ; $self -> send_notification ({ type => 'event', event => $event, body => $body }, $self) ; } # --------------------------------------------------------------------------- sub send_request { my ($self, $command, $body) = @_ ; return $self -> debug_adapter_interface -> request ({ command => $command, $body?%$body:() }) ; } # --------------------------------------------------------------------------- sub _dapreq_initialize { my ($self, $workspace, $req) = @_ ; $self -> log_prefix ('DA') ; $Perl::LanguageServer::dev_tool = Perl::LanguageServer::DevTool -> new ({ config => $req -> params }) ; $Perl::LanguageServer::workspace ||= Perl::LanguageServer::Workspace -> new ({ config =>{} }) ; #$self -> logger ('initialize debug adapter', dump ($req -> params),"\n") ; my $caps = { # The debug adapter supports the 'configurationDone' request. supportsConfigurationDoneRequest => JSON::true(), # The debug adapter supports function breakpoints. supportsFunctionBreakpoints => JSON::false(), # The debug adapter supports conditional breakpoints. supportsConditionalBreakpoints => JSON::true(), # The debug adapter supports breakpoints that break execution after a specified number of hits. supportsHitConditionalBreakpoints => JSON::false(), # The debug adapter supports a (side effect free) evaluate request for data hovers. supportsEvaluateForHovers => JSON::true(), # Available filters or options for the setExceptionBreakpoints request. exceptionBreakpointFilters => [], # The debug adapter supports stepping back via the 'stepBack' and 'reverseContinue' requests. supportsStepBack => JSON::false(), # The debug adapter supports setting a variable to a value. supportsSetVariable => JSON::true(), # The debug adapter supports restarting a frame. supportsRestartFrame => JSON::false(), # The debug adapter supports the 'gotoTargets' request. supportsGotoTargetsRequest => JSON::false(), # The debug adapter supports the 'stepInTargets' request. supportsStepInTargetsRequest => JSON::false(), # The debug adapter supports the 'completions' request. supportsCompletionsRequest => JSON::false(), # The set of characters that should trigger completion in a REPL. If not specified, the UI should assume the '.' character. completionTriggerCharacters => [], # The debug adapter supports the 'modules' request. supportsModulesRequest => JSON::true(), # The set of additional module information exposed by the debug adapter. additionalModuleColumns => [], # Checksum algorithms supported by the debug adapter. supportedChecksumAlgorithms => [], # The debug adapter supports the 'restart' request. In this case a client should not implement 'restart' by terminating and relaunching the adapter but by calling the RestartRequest. supportsRestartRequest => JSON::false(), # The debug adapter supports 'exceptionOptions' on the setExceptionBreakpoints request. supportsExceptionOptions => JSON::false(), # The debug adapter supports a 'format' attribute on the stackTraceRequest, variablesRequest, and evaluateRequest. supportsValueFormattingOptions => JSON::false(), # The debug adapter supports the 'exceptionInfo' request. supportsExceptionInfoRequest => JSON::false(), # The debug adapter supports the 'terminateDebuggee' attribute on the 'disconnect' request. supportTerminateDebuggee => JSON::true(), # The debug adapter supports the delayed loading of parts of the stack, which requires that both the 'startFrame' and 'levels' arguments and the 'totalFrames' result of the 'StackTrace' request are supported. supportsDelayedStackTraceLoading => JSON::true(), # The debug adapter supports the 'loadedSources' request. supportsLoadedSourcesRequest => JSON::true(), # The debug adapter supports logpoints by interpreting the 'logMessage' attribute of the SourceBreakpoint. supportsLogPoints => JSON::false(), # The debug adapter supports the 'terminateThreads' request. supportsTerminateThreadsRequest => JSON::true(), # The debug adapter supports the 'setExpression' request. supportsSetExpression => JSON::true(), # The debug adapter supports the 'terminate' request. supportsTerminateRequest => JSON::true(), # The debug adapter supports data breakpoints. supportsDataBreakpoints => JSON::false(), # The debug adapter supports the 'readMemory' request. supportsReadMemoryRequest => JSON::false(), # The debug adapter supports the 'disassemble' request. supportsDisassembleRequest => JSON::false(), # The debug adapter supports the 'cancel' request. supportsCancelRequest => JSON::true(), # The debug adapter supports the 'breakpointLocations' request. supportsBreakpointLocationsRequest => JSON::true(), } ; return $caps ; } # --------------------------------------------------------------------------- sub _check_not_running { my ($self, $workspace) = @_ ; if ($self -> running) { die "Debuggee is running" ; } return ; } # --------------------------------------------------------------------------- sub _temp_break { my ($self, $workspace) = @_ ; my $running = $self -> running ; return if (!$running) ; my $temp_break_guard = Guard::guard { $self -> _temp_cont ($workspace, $running) ; } ; my $cnt = 50 ; my $itb = $self -> in_temp_break ; $self -> in_temp_break ($itb + 1) ; $self -> logger ("in_temp_break = ", $itb + 1, "\n") ; $self -> _dapreq_pause ($workspace) if ($itb == 0); while ($self -> running && $cnt-- > 0) { Coro::AnyEvent::sleep (0.1) ; } $self -> _check_not_running ($workspace) ; $running = 0 if (!$self -> in_temp_break) ; return $temp_break_guard ; } # --------------------------------------------------------------------------- sub _temp_cont { my ($self, $workspace, $old_running) = @_ ; my $itb = $self -> in_temp_break ; $self -> logger ("temp_cont = $itb old_running = $old_running\n") ; return if (!$old_running) ; return if ($itb == 0) ; $self -> in_temp_break ($itb - 1) ; if ($itb == 1) { $self -> running (1) ; $self -> send_request ('continue') ; } } # --------------------------------------------------------------------------- sub _set_breakpoints { my ($self, $workspace, $req, $location, $breakpoints, $source) = @_ ; my $temp_break_guard = $self -> _temp_break ($workspace) ; my @bp ; for (my $i; $i < @$breakpoints; $i++) { push @bp, [$breakpoints -> [$i]{$location}, $breakpoints -> [$i]{condition}] } my $ret = $self -> send_request ('breakpoint', { breakpoints => \@bp, ($source?(filename => $self -> debugger_process -> file_client2server ($workspace, $source -> {path})):()), }) ; if ($req -> params -> {real_filename}) { $workspace -> add_path_mapping ($req -> params -> {real_filename}, $self -> debugger_process -> file_server2client ($workspace, $req -> params -> {req_filename})) } my @setbp ; for (my $i; $i < @{$ret -> {breakpoints}}; $i++) { my $bp = $ret -> {breakpoints}[$i] ; push @setbp, { verified => $bp -> [2]?JSON::true ():JSON::false (), message => $bp -> [3], line => $bp -> [4]+0, id => $bp -> [6]+0, source => { path => $self -> debugger_process -> file_server2client ($workspace, $bp -> [5]) }, } } return { breakpoints => \@setbp } ; } # --------------------------------------------------------------------------- sub _dapreq_setBreakpoints { my ($self, $workspace, $req) = @_ ; my $breakpoints = $req -> params -> {breakpoints} ; my $source = $req -> params -> {source} ; return { breakpoints => [] } if (!$breakpoints || !$source); return $self -> _set_breakpoints ($workspace, $req, 'line', $breakpoints, $source) ; } # --------------------------------------------------------------------------- sub _dapreq_setFunctionBreakpoints { my ($self, $workspace, $req) = @_ ; my $breakpoints = $req -> params -> {breakpoints} ; return { breakpoints => [] } if (!$breakpoints); return $self -> _set_breakpoints ($workspace, $req, 'name', $breakpoints) ; } # --------------------------------------------------------------------------- sub _dapreq_setExceptionBreakpoints { my ($self, $workspace, $req) = @_ ; return {} ; } # --------------------------------------------------------------------------- sub _dapreq_breakpointLocations { my ($self, $workspace, $req) = @_ ; my $dai = $self -> debug_adapter_interface ; return { breakpoints => [] } if (!$dai || !$dai -> initialized) ; my $temp_break_guard = $self -> _temp_break ($workspace) ; my $source = $req -> params -> {source} ; my $ret = $self -> send_request ('can_break', { line => $req -> params -> {line}, end_line => $req -> params -> {endLine}, ($source?(filename => $self -> debugger_process -> file_client2server ($workspace, $source -> {path})):()), }) ; foreach (@{$ret -> {breakpoints}}) { $_ -> {line} += 0 ; } return $ret ; } # --------------------------------------------------------------------------- sub _dapreq_configurationDone { my ($self, $workspace, $req) = @_ ; if (!$self -> debugger_process -> stop_on_entry) { $self -> running (1) ; $self -> send_request ('continue') ; $self -> send_event ('continued', { allThreadsContinued => JSON::true() }) ; } return {} ; } # --------------------------------------------------------------------------- sub _dapreq_launch { my ($self, $workspace, $req) = @_ ; $self -> _check_not_running ($workspace) ; $self -> running (1) ; my $proc = Perl::LanguageServer::DebuggerProcess -> new ($req -> params) ; $self -> debugger_process ($proc) ; $proc -> debug_adapter ($self) ; $debug_adapters{$proc -> session_id} = $self ; $proc -> launch ($workspace, $workspace -> perlcmd) ; return {} ; } # --------------------------------------------------------------------------- sub _dapreq_loadedSources { my ($self, $workspace, $req) = @_ ; my @sources = ( { path => $self -> debugger_process -> program }); return { sources => \@sources } ; } # --------------------------------------------------------------------------- sub _dapreq_threads { my ($self, $workspace, $req) = @_ ; $self -> _check_not_running ($workspace) ; my $threads = $self -> send_request ('threads') ; foreach (@{$threads -> {threads}}) { $_ -> {id} = $self -> getid (0, $_ -> {thread_ref}) ; } return $threads ; } # --------------------------------------------------------------------------- sub _dapreq_stackTrace { my ($self, $workspace, $req) = @_ ; $self -> _check_not_running ($workspace) ; my $thread_ref = $self -> id2ref -> {$req -> params -> {threadId}} -> {ref} ; my $frames = $self -> send_request ('stack', { thread_ref => $thread_ref, levels => $req -> params -> {levels}, start => $req -> params -> {startFrame}, }) ; foreach (@{$frames -> {stackFrames}}) { $_ -> {id} = $self -> getid ($req -> params -> {threadId}, $_ -> {frame_ref}, { thread_ref => $thread_ref, package => $_ -> {'package'} }) ; $_ -> {line} += 0 ; $_ -> {column} += 0 ; $_ -> {source}{path} = $self -> debugger_process -> file_server2client ($workspace, $_ -> {source}{path}) ; } return $frames ; } # --------------------------------------------------------------------------- sub _dapreq_scopes { my ($self, $workspace, $req) = @_ ; $self -> _check_not_running ($workspace) ; my $ref = $self -> id2ref -> {$req -> params -> {frameId}} ; my $frame_ref = $ref -> {ref} ; my $thread_ref = $ref -> {thread_ref} ; my $package = $ref -> {package} ; return { scopes => [ { name => 'Locals', presentationHint => 'locals', expensive => JSON::false (), variablesReference => $self -> getid ($req -> params -> {frameId}, 'l', { frame_ref => $frame_ref, thread_ref => $thread_ref, package => $package }), }, { name => 'Globals', presentationHint => 'globals', expensive => JSON::true (), variablesReference => $self -> getid ($req -> params -> {frameId}, 'g', { frame_ref => $frame_ref, thread_ref => $thread_ref, package => $package }), }, { name => 'Specials', presentationHint => 'specials', expensive => JSON::true (), variablesReference => $self -> getid ($req -> params -> {frameId}, 's', { frame_ref => $frame_ref, thread_ref => $thread_ref, package => $package }), }, { name => 'Arguments', presentationHint => 'arguments', expensive => JSON::true (), variablesReference => $self -> getid ($req -> params -> {frameId}, 'a', { frame_ref => $frame_ref, thread_ref => $thread_ref, package => $package }), }, ] } ; } # --------------------------------------------------------------------------- sub _dapreq_variables { my ($self, $workspace, $req) = @_ ; $self -> _check_not_running ($workspace) ; my $params = $req -> params ; my $ref = $self -> id2ref -> {$params -> {variablesReference}} ; my $frame_ref = $ref -> {frame_ref} ; my $thread_ref = $ref -> {thread_ref} ; my $package = $ref -> {package} ; my $type = $ref -> {ref} ; #use Data::Dump ; #print STDERR Data::Dump::pp($self -> id2ref), "\n" ; my $variables = $self -> send_request ('vars', { thread_ref => $thread_ref, frame_ref => $frame_ref, 'package' => $package, type => $type, #var_ref => $ref, count => $params -> {count}, start => $params -> {start}, filter => $params -> {filter}, }) ; foreach (@{$variables -> {variables}}) { $_ -> {variablesReference} = $_ -> {var_ref}?$self -> getid ($req -> params -> {variablesReference}, $_ -> {var_ref}, { frame_ref => $frame_ref, thread_ref => $thread_ref, 'package' => $package, type => $type}): 0 ; $_ -> {name} .= '' ; # make sure name is a string, otherwise array indices fails on mac } return $variables ; } # --------------------------------------------------------------------------- sub _dapreq_setVariable { my ($self, $workspace, $req) = @_ ; $self -> _check_not_running ($workspace) ; my $params = $req -> params ; my $ref = $self -> id2ref -> {$params -> {variablesReference}} ; my $frame_ref = $ref -> {frame_ref} ; my $thread_ref = $ref -> {thread_ref} ; my $package = $ref -> {package} ; my $type = $ref -> {ref} ; my $expr = $params->{value} ; my $setvar = $params->{name} ; my $result = $self -> send_request ('setvar', { thread_ref => $thread_ref, frame_ref => $frame_ref, 'package' => $package, expression => $expr, type => $type, setvar => $setvar, }) ; $result -> {variablesReference} = $result -> {var_ref}?$self -> getid ($req -> params -> {variablesReference}, $result -> {var_ref}, { frame_ref => $frame_ref, thread_ref => $thread_ref, 'package' => $package, }): 0 ; return $result ; } # --------------------------------------------------------------------------- sub _dapreq_source { my ($self, $workspace, $req) = @_ ; my $source = $req -> params -> {source} ; $self -> logger ("req_source source =" . pp($source)) ; my $ret = $self -> send_request ('source', { ($source?(filename => $self -> debugger_process -> file_client2server ($workspace, $source -> {path})):()), }) ; $self -> logger ("_dapreq_source ret = " . pp($ret)) ; return $ret; } # --------------------------------------------------------------------------- sub _dapreq_evaluate { my ($self, $workspace, $req) = @_ ; $self -> _check_not_running ($workspace) ; my $ref = $self -> id2ref -> {$req -> params -> {frameId}} ; my $frame_ref = $ref -> {ref} ; my $thread_ref = $ref -> {thread_ref} ; my $package = $ref -> {package} ; my $result = $self -> send_request ('evaluate', { thread_ref => $thread_ref, frame_ref => $frame_ref, 'package' => $package, expression => $req -> params -> {expression}, context => $req -> params -> {context}, }) ; $result -> {variablesReference} = $result -> {var_ref}?$self -> getid ($req -> params -> {variablesReference}, $result -> {var_ref}, { frame_ref => $frame_ref, thread_ref => $thread_ref, 'package' => $package, }): 0 ; $result -> {result} = delete $result -> {value} ; return $result ; } # --------------------------------------------------------------------------- sub _dapreq_pause { my ($self, $workspace, $req) = @_ ; $self -> logger ("send SIGINT for pause\n") ; $self -> debugger_process -> signal ('INT') ; return {} ; } # --------------------------------------------------------------------------- sub _dapreq_terminate { my ($self, $workspace, $req) = @_ ; $self -> debugger_process -> signal ('TERM') ; return {} ; } # --------------------------------------------------------------------------- sub _dapreq_disconnect { my ($self, $workspace, $req) = @_ ; $self -> debugger_process -> signal ('KILL') ; return {} ; } # --------------------------------------------------------------------------- sub _dapreq_continue { my ($self, $workspace, $req) = @_ ; $self -> _check_not_running ($workspace) ; $self -> running (1) ; $self -> send_request ('continue', $req?{ thread_id => $req -> {threadId}}:undef) ; return {} ; } # --------------------------------------------------------------------------- sub _dapreq_stepIn { my ($self, $workspace, $req) = @_ ; $self -> _check_not_running ($workspace) ; $self -> running (1) ; $self -> send_request ('step_in', { thread_id => $req -> {threadId}}) ; return {} ; } # --------------------------------------------------------------------------- sub _dapreq_stepOut { my ($self, $workspace, $req) = @_ ; $self -> _check_not_running ($workspace) ; $self -> running (1) ; $self -> send_request ('step_out', { thread_id => $req -> {threadId}}) ; return {} ; } # --------------------------------------------------------------------------- sub _dapreq_next { my ($self, $workspace, $req) = @_ ; $self -> _check_not_running ($workspace) ; $self -> running (1) ; $self -> send_request ('next', { thread_id => $req -> {threadId}}) ; return {} ; } 1 ; Perl-LanguageServer-2.6.2/lib/Perl/LanguageServer/Parser.pm0000644000000000000000000004763114534024141022216 0ustar rootrootpackage Perl::LanguageServer::Parser ; use Moose::Role ; use Coro ; use Coro::AIO ; use JSON ; use File::Basename ; use v5.16; no warnings 'uninitialized' ; use Compiler::Lexer; use Data::Dump qw{dump} ; use constant SymbolKindFile => 1; use constant SymbolKindModule => 2; use constant SymbolKindNamespace => 3; use constant SymbolKindPackage => 4; use constant SymbolKindClass => 5; use constant SymbolKindMethod => 6; use constant SymbolKindProperty => 7; use constant SymbolKindField => 8; use constant SymbolKindConstructor => 9; use constant SymbolKindEnum => 10; use constant SymbolKindInterface => 11; use constant SymbolKindFunction => 12; use constant SymbolKindVariable => 13; use constant SymbolKindConstant => 14; use constant SymbolKindString => 15; use constant SymbolKindNumber => 16; use constant SymbolKindBoolean => 17; use constant SymbolKindArray => 18; use constant SymbolKindObject => 19; use constant SymbolKindKey => 20; use constant SymbolKindNull => 21; use constant SymbolKindEnumMember => 22; use constant SymbolKindStruct => 23; use constant SymbolKindEvent => 24; use constant SymbolKindOperator => 25; use constant SymbolKindTypeParameter => 26; use constant CacheVersion => 5 ; # --------------------------------------------------------------------------- sub _get_docu { my ($self, $source, $line) = @_ ; my @docu ; my $in_pod ; while ($line-- >= 0) { my $src = $source -> [$line] ; if ($src =~ /^=cut/) { $in_pod = 1 ; next ; } if ($in_pod) { last if ($src =~ /^=pod/) ; next if ($src =~ /^=\w+\s*$/) ; $src =~ s/^=item /* / ; unshift @docu, $src ; } else { next if ($src =~ /^\s*$/) ; next if ($src =~ /^\s*#[-#+~= \t]+$/) ; last if ($src !~ /^\s*#(.*?)\s*$/) ; unshift @docu, $1 ; } } shift @docu while (@docu && ($docu[0] =~ /^\s*$/)) ; pop @docu while (@docu && ($docu[-1] =~ /^\s*$/)) ; return join ("\n", @docu) ; } # --------------------------------------------------------------------------- sub parse_perl_source { my ($self, $uri, $source, $server) = @_ ; $source =~ s/\r//g ; # Compiler::Lexer computes wrong line numbers with \r my @source = split /\n/, $source ; my $lexer = Compiler::Lexer->new(); my $tokens = $lexer->tokenize($source); cede () ; #$server -> logger (dump ($tokens) . "\n") ; #my $modules = $lexer->get_used_modules($script); my @vars ; my $package = 'main::' ; my %state ; my $decl ; my $declline ; my $func ; my $parent ; my $top ; my $add ; my $func_param ; my $token_ndx = -1 ; my $brace_level = 0 ; my @stack ; my $beginchar = 0 ; my $endchar = 0 ; foreach my $token (@$tokens) { $token_ndx++ ; $token -> {data} =~ s/\r$// ; $server -> logger ("token=", dump ($token), "\n") if ($Perl::LanguageServer::debug3) ; if (exists $state{method_mod} && $token -> {name} eq 'RawString') { $token -> {name} = 'Function' ; delete $state{method_mod} ; } my $name = $token -> {name} ; if ($name =~ /^(?:VarDecl|OurDecl|FunctionDecl)$/) { $decl = $token -> {data}, $declline = $token -> {line} ; } elsif ($name =~ /Var$/) { $top = $decl eq 'our' || !$parent?\@vars:$parent ; push @$top, { name => $token -> {data}, kind => SymbolKindVariable, containerName => $decl eq 'our'?$package:$func, ($decl?(definition => $decl):()), ($decl eq 'my'?(localvar => $decl):()), } ; $add = $top -> [-1] ; $token -> {line} = $declline if ($decl) ; $decl = undef ; } elsif ($name eq 'LeftBrace') { $brace_level++ ; $decl = undef ; if (@vars && $vars[-1]{kind} == SymbolKindVariable) { $vars[-1]{name} =~ s/^\$/%/ ; } } elsif ($name =~ /^(?:RightBrace|SemiColon)$/) { $brace_level-- if ($name eq 'RightBrace') ; if (@stack > 0 && $brace_level == $stack[-1]{brace_level}) { my $stacktop = pop @stack ; $parent = $stacktop -> {parent} ; $func = $stacktop -> {func} ; my $symbol = $stacktop -> {symbol} ; my $start_line = $symbol -> {range}{start}{line} // $symbol -> {line} ; $symbol -> {range} = { start => { line => $start_line, character => 0 }, end => { line => $token -> {line}-1, character => 9999 }} if (defined ($start_line)) ; } if ($name eq 'SemiColon') { $decl = undef ; # continue does only work in switch statement, which is deprecated and was removed # unclear, if this is still necessray? #continue ; } } elsif ($name eq 'LeftBracket') { if (@vars && $vars[-1]{kind} == SymbolKindVariable) { $vars[-1]{name} =~ s/^\$/@/ ; } } elsif ($name =~ /^(?:Function|Method)$/) { if ($token -> {data} =~ /^\w/) { $top = !$parent?\@vars:$parent ; push @$top, { name => $token -> {data}, kind => SymbolKindFunction, containerName => @stack?$func:$package, ($decl?(definition => $decl):()), } ; $func_param = $add = $top -> [-1] ; if ($decl) { push @stack, { brace_level => $brace_level, parent => $parent, func => $func, 'package' => $package, symbol => $add, } ; $token -> {line} = $declline ; $func = $token -> {data} ; $parent = $top -> [-1]{children} ||= [] ; } my $src = $source[$token -> {line}-1] ; my $i ; if ($src && ($i = index($src, $func) >= 0)) { $beginchar = $i + 1 ; $endchar = $i + 1 + length ($func) ; } } $decl = undef ; } elsif ($name eq 'ArgumentArray') { if ($func_param) { my @params ; if ($tokens -> [$token_ndx - 1]{name} eq 'Assign' && $tokens -> [$token_ndx - 2]{name} eq 'RightParenthesis') { for (my $i = $token_ndx - 3; $i >= 0; $i--) { next if ($tokens -> [$i]{name} eq 'Comma') ; last if ($tokens -> [$i]{name} !~ /Var$/) ; push @params, $tokens -> [$i]{data} ; } my $func_doc = $self -> _get_docu (\@source, $func_param -> {range}{start}{line} // $func_param -> {line}) ; my @parameters ; foreach my $p (reverse @params) { push @parameters, { label => $p, } ; } $func_param -> {detail} = '(' . join (',', reverse @params) . ')' ; $func_param -> {signature} = { label => $func_param -> {name} . $func_param -> {detail}, documentation => $func_doc, parameters => \@parameters } ; } $func_param = undef ; } } elsif ($name eq 'Prototype') { if ($func_param) { my @params = split /\s*,\s*/, $token -> {data} ; my $func_doc = $self -> _get_docu (\@source, $func_param -> {range}{start}{line} // $func_param -> {line}) ; my @parameters ; foreach my $p (@params) { push @parameters, { label => $p, } ; } $func_param -> {detail} = '(' . join (',', @params) . ')' ; $func_param -> {signature} = { label => $func_param -> {name} . $func_param -> {detail}, documentation => $func_doc, parameters => \@parameters } ; $func_param = undef ; } } elsif ($name =~ /^(?:Package|UseDecl)$/) { $state{is} = $token -> {data} ; $state{module} = 1 ; } elsif ($name =~ /^(?:ShortHashDereference|ShortArrayDereference)$/) { $state{scalar} = '$' ; } elsif ($name eq 'Key') { if (exists ($state{constant})) { $top = \@vars ; push @$top, { name => $token -> {data}, kind => SymbolKindConstant, containerName => $package, definition => 1, } ; $add = $top -> [-1] ; } elsif (exists ($state{scalar})) { $top = $decl eq 'our' || !$parent?\@vars:$parent ; push @$top, { name => $state{scalar} . $token -> {data}, kind => SymbolKindVariable, containerName => $decl eq 'our'?$package:$func, } ; $add = $top -> [-1] ; } elsif ($token -> {data} =~ /^(?:has|class_has)$/) { $state{has} = 1 ; } elsif ($token -> {data} =~ /^(?:around|before|after)$/) { $state{method_mod} = 1 ; $decl = $token -> {data}, $declline = $token -> {line} ; } elsif ($token -> {data} =~ /^[a-z_][a-z0-9_]+$/i) { $top = \@vars ; push @$top, { name => $token -> {data}, kind => SymbolKindFunction, } ; $add = $top -> [-1] ; } } elsif ($name eq 'RawString') { if (exists ($state{has})) { $top = \@vars ; push @$top, { name => $token -> {data}, kind => SymbolKindProperty, containerName => $package, definition => 1, } ; $add = $top -> [-1] ; } } elsif ($name eq 'UsedName') { if ($token -> {data} eq 'constant') { delete $state{module} ; $state{constant} = 1 ; } else { $state{ns} = [$token->{data}] ; } } elsif($name eq 'Namespace') { $state{ns} ||= [] ; push @{$state{ns}}, $token -> {data} ; } elsif ($name eq 'NamespaceResolver') { # make sure it is not matched below } elsif ($name eq 'Assign' or $token -> {data} =~ /^\W/) { if ($name eq 'Assign') { $decl = undef ; } if (exists ($state{ns})) { if ($state{module}) { my $def ; if ($state{is} eq 'package') { $def = 1 ; $package = join ('::', @{$state{ns}}) ; $top = \@vars ; push @$top, { name => $package, kind => SymbolKindModule, #containerName => join ('::', @{$state{ns}}), #($def?(definition => $def):()), definition => 1, } ; $add = $top -> [-1] ; } else { my $name = pop @{$state{ns}} ; $top = \@vars ; push @$top, { name => $name, kind => SymbolKindModule, containerName => join ('::', @{$state{ns}}), ($def?(definition => $def):()), } ; $add = $top -> [-1] ; } } else { my $name = shift @{$state{ns}} ; $top = \@vars ; push @$top, { name => $name, kind => SymbolKindFunction, containerName => join ('::', @{$state{ns}}), } ; $add = $top -> [-1] ; } } %state = () ; } if ($add) { if (!$uri) { $add -> {line} = $token -> {line}-1 ; } else { #$add -> {location} = { uri => $uri, range => { start => { line => $token -> {line}-1, character => 0 }, end => { line => $token -> {line}-1, character => 0 }}} ; $add -> {range} = { start => { line => $token -> {line}-1, character => 0 }, end => { line => $token -> {line}-1, character => ($endchar?9999:0) }} ; $add -> {selectionRange} = { start => { line => $token -> {line}-1, character => $beginchar }, end => { line => $token -> {line}-1, character => $endchar }} ; $beginchar = $endchar = 0 ; } $server -> logger ("var=", dump ($add), "\n") if ($Perl::LanguageServer::debug3) ; $add = undef ; } } $server -> logger (dump (\@vars), "\n") if ($Perl::LanguageServer::debug3) ; return wantarray?(\@vars, $tokens):\@vars ; } # ---------------------------------------------------------------------------- sub _parse_perl_source_cached { my ($self, $uri, $source, $path, $stats, $server) = @_ ; my $cachepath ; if (!$self -> disable_cache) { my $escpath = $path ; $escpath =~ s/:/%3A/ ; $cachepath = $self -> state_dir .'/' . $escpath ; $self -> mkpath (dirname ($cachepath)) ; #$server -> logger ("$path -> cachepath=$cachepath\n") ; aio_stat ($cachepath) ; if (-e _) { my $mtime_cache = -M _ ; aio_stat ($path) ; my $mtime_src = -M _ ; #$server -> logger ("cache = $mtime_cache src = $mtime_src\n") ; if ($mtime_src > $mtime_cache) { #$server -> logger ("load from cache\n") ; my $cache ; aio_load ($cachepath, $cache) ; my $cache_data = eval { $Perl::LanguageServer::json -> decode ($cache) ; } ; if ($@) { $self -> logger ("Loading of $cachepath failed, reparse file ($@)\n") ; } elsif (ref ($cache_data) eq 'HASH') { if ($cache_data -> {version} == CacheVersion) { $stats -> {loaded}++ ; return $cache_data -> {vars} ; } } } } } my $vars = $self -> parse_perl_source ($uri, $source, $server) ; if ($cachepath) { my $ifh = aio_open ($cachepath, IO::AIO::O_WRONLY | IO::AIO::O_TRUNC | IO::AIO::O_CREAT, 0664) or die "open $cachepath failed ($!)" ; aio_write ($ifh, undef, undef, $Perl::LanguageServer::json -> encode ({ version => CacheVersion, vars => $vars}), 0) ; aio_close ($ifh) ; } $stats -> {parsed}++ ; return $vars ; } # ---------------------------------------------------------------------------- sub _parse_dir { my ($self, $server, $dir, $vars, $stats) = @_ ; my $text ; my $fn ; my $uri ; my $file_vars ; my $filefilter = $self -> file_filter_regex ; my $ignore_dir = $self -> ignore_dir ; my ($dirs, $files) = aio_scandir ($dir, 4) ; if ($dirs) { foreach my $d (sort @$dirs) { next if (exists $ignore_dir -> {$d}) ; $self -> _parse_dir ($server, $dir . '/' . $d, $vars, $stats) ; } } if ($files) { foreach my $f (sort @$files) { next if ($f !~ /$filefilter/) ; $fn = $dir . '/' . $f ; aio_load ($fn, $text) ; $uri = $self -> uri_server2client ('file://' . $fn) ; #$server -> logger ("parse $fn -> $uri\n") ; $file_vars = $self -> _parse_perl_source_cached (undef, $text, $fn, $stats, $server) ; $vars -> {$uri} = $file_vars ; #$server -> logger ("done $fn\n") ; my $cnt = keys %$vars ; $server -> logger ("loaded $stats->{loaded} files, parsed $stats->{parsed} files, $cnt files\n") if ($cnt % 100 == 0) ; } } } # ---------------------------------------------------------------------------- sub background_parser { my ($self, $server) = @_ ; my $channel = $self -> parser_channel ; $channel -> shutdown ; # end other parser cede ; $channel = $self -> parser_channel (Coro::Channel -> new) ; my $folders = $self -> folders ; $server -> logger ("background_parser folders = ", dump ($folders), "\n") ; %{$self -> symbols} = () ; my $stats = {} ; foreach my $dir (values %$folders) { $self -> _parse_dir ($server, $dir, $self -> symbols, $stats) ; cede ; } my $cnt = keys %{$self -> symbols} ; $server -> logger ("initial parsing done, loaded $stats->{loaded} files, parsed $stats->{parsed} files, $cnt files\n") ; my $filefilter = $self -> file_filter_regex ; while (my $item = $channel -> get) { my ($cmd, $uri) = @$item ; my $fn = substr ($self -> uri_client2server ($uri), 7) ; next if (basename ($fn) !~ /$filefilter/) ; my $text ; aio_load ($fn, $text) ; $server -> logger ("parse $fn -> $uri\n") ; my $file_vars = $self -> _parse_perl_source_cached (undef, $text, $fn, {}, $server) ; $self -> symbols -> {$uri} = $file_vars ; } $server -> logger ("background_parser quit\n") ; } 1 ; Perl-LanguageServer-2.6.2/lib/Perl/LanguageServer/DebuggerBridge.pm0000644000000000000000000000220614370011743023612 0ustar rootrootpackage Perl::LanguageServer::DebuggerBridge ; use 5.006; use strict; use IO::Socket ; use IO::Select; no warnings 'uninitialized' ; sub run { my $socket ; my $proto = getprotobyname ('tcp') ; my $ip = '127.0.0.1' ; my $port = $ARGV[0] || 13603 ; socket ($socket, PF_INET, SOCK_STREAM, $proto) or die "Can't create a socket $!\n" ; connect ($socket, pack_sockaddr_in ($port, inet_aton ($ip))) or die "Can't connect to $ip:$port $!\n" ; my $stdin = \*STDIN ; my $s = IO::Select->new(); $s->add($stdin); $s->add($socket); my $timeout = 0 ; my @ready ; while (@ready = $s->can_read()) { while (my $fh = shift @ready) { if ($fh == $stdin) { my $data ; exit if (sysread ($fh, $data, 16384) <= 0) ; syswrite ($socket, $data) ; } elsif ($fh == $socket) { my $data ; exit if (sysread ($fh, $data, 16384) <= 0) ; syswrite (\*STDOUT, $data) ; } } } } 1 ;Perl-LanguageServer-2.6.2/lib/Perl/LanguageServer/Methods.pm0000644000000000000000000001441014370011453022352 0ustar rootrootpackage Perl::LanguageServer::Methods ; use Moose::Role ; use JSON ; use Data::Dump qw{pp} ; no warnings 'uninitialized' ; # --------------------------------------------------------------------------- sub _rpcreq_initialize { my ($self, $workspace, $req) = @_ ; #print STDERR "Call initialize\n" ; $self -> logger ("initialize ", $Perl::LanguageServer::jsonpretty -> encode ($req -> params), "\n") if ($Perl::LanguageServer::debug1) ; $Perl::LanguageServer::workspace = Perl::LanguageServer::Workspace -> new ({ config => $req -> params }) ; my $caps = { # Defines how text documents are synced. Is either a detailed structure defining each notification or # for backwards compatibility the TextDocumentSyncKind number. If omitted it defaults to `TextDocumentSyncKind.None`. textDocumentSync => 1, # full # The server provides hover support. #hoverProvider?: boolean; # The server provides completion support. #completionProvider?: CompletionOptions; # The server provides signature help support. #signatureHelpProvider?: SignatureHelpOptions; signatureHelpProvider => { triggerCharacters => ['('], }, # The server provides goto definition support. #definitionProvider?: boolean; definitionProvider => JSON::true, # The server provides Goto Type Definition support. # Since 3.6.0 #typeDefinitionProvider?: boolean | (TextDocumentRegistrationOptions & StaticRegistrationOptions); # The server provides Goto Implementation support. # Since 3.6.0 #implementationProvider?: boolean | (TextDocumentRegistrationOptions & StaticRegistrationOptions); # The server provides find references support. referencesProvider => JSON::true, # The server provides document highlight support. #documentHighlightProvider?: boolean; # The server provides document symbol support. #documentSymbolProvider?: boolean; documentSymbolProvider => JSON::true, # The server provides workspace symbol support. workspaceSymbolProvider => JSON::true, # The server provides code actions. #codeActionProvider?: boolean; # The server provides code lens. #codeLensProvider?: CodeLensOptions; # The server provides document formatting. #documentFormattingProvider?: boolean; #documentFormattingProvider => JSON::true, # The server provides document range formatting. #documentRangeFormattingProvider?: boolean; documentRangeFormattingProvider => JSON::true, # The server provides document formatting on typing. #documentOnTypeFormattingProvider?: DocumentOnTypeFormattingOptions; # The server provides rename support. #renameProvider?: boolean; # The server provides document link support. #documentLinkProvider?: DocumentLinkOptions; # The server provides color provider support. # Since 3.6.0 #colorProvider?: boolean | ColorProviderOptions | (ColorProviderOptions & TextDocumentRegistrationOptions & StaticRegistrationOptions); # The server provides execute command support. #executeCommandProvider?: ExecuteCommandOptions; # The server provides selection range support. # @since 3.15.0 # selectionRangeProvider?: boolean | SelectionRangeOptions | SelectionRangeRegistrationOptions; #selectionRangeProvider => JSON::true, # Workspace specific server capabilities workspace => { # The server supports workspace folder. # Since 3.6.0 workspaceFolders => { # The server has support for workspace folders supported => JSON::true, # * Whether the server wants to receive workspace folder # * change notifications. # * # * If a strings is provided the string is treated as a ID # * under which the notification is registered on the client # * side. The ID can be used to unregister for these events # * using the `client/unregisterCapability` request. # */ changeNotifications => JSON::true, } } # Experimental server capabilities. #experimental?: any; } ; return { capabilities => $caps } ; } # --------------------------------------------------------------------------- sub _rpcnot_initialized { my ($self, $workspace, $req) = @_ ; return if (!$Perl::LanguageServer::client_version) ; if ($Perl::LanguageServer::client_version ne $Perl::LanguageServer::VERSION) { my $msg = "Version of IDE/Editor plugin is $Perl::LanguageServer::client_version\nVersion of Perl::LanguageServer is $Perl::LanguageServer::VERSION\nPlease make sure you run matching versions of the plugin and the Perl::LanguageServer module\nUse 'cpan Perl::LanguageServer' to install the newest version of the Perl::LanguageServer module\n" ; $self -> logger ("\n$msg\n") ; } return ; } # --------------------------------------------------------------------------- sub _rpcnot_cancelRequest { my ($self, $workspace, $req) = @_ ; my $cancel_id = $req -> params -> {id} ; return if (!$cancel_id) ; return if (!exists $Perl::LanguageServer::running_req{$cancel_id}) ; $Perl::LanguageServer::running_req{$cancel_id} -> cancel_req ; return ; } # --------------------------------------------------------------------------- sub _rpcreq_shutdown { my ($self, $workspace, $req) = @_ ; return if (!$workspace) ; $workspace -> shutdown ; } # --------------------------------------------------------------------------- sub _rpcnot_exit { my ($self, $workspace, $req) = @_ ; print STDERR "Exit\n" ; exit (1) if (!$workspace) ; exit (1) if (!$workspace -> is_shutdown) ; exit (0) ; return ; } # --------------------------------------------------------------------------- 1 ; Perl-LanguageServer-2.6.2/lib/Perl/LanguageServer/DevTool.pm0000644000000000000000000000063614370011534022330 0ustar rootrootpackage Perl::LanguageServer::DevTool ; use 5.006; use strict; use Moose ; use File::Basename ; use Coro ; use Coro::AIO ; use Data::Dump qw{dump} ; no warnings 'uninitialized' ; # --------------------------------------------------------------------------- has 'config' => ( isa => 'HashRef', is => 'ro' ) ; # --------------------------------------------------------------------------- 1 ; Perl-LanguageServer-2.6.2/lib/Perl/LanguageServer/Workspace.pm0000644000000000000000000002200114457251204022706 0ustar rootrootpackage 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 'use_taint_for_syntax_check' => ( isa => 'Maybe[Bool]', 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, $map) = @_ ; $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 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) { 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 ; Perl-LanguageServer-2.6.2/lib/Perl/LanguageServer/DebuggerProcess.pm0000644000000000000000000001607114456574413024056 0ustar rootrootpackage 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 ; Perl-LanguageServer-2.6.2/lib/Perl/LanguageServer/SyntaxChecker.pm0000644000000000000000000002620214457251204023532 0ustar rootrootpackage Perl::LanguageServer::SyntaxChecker ; use Moose::Role ; use strict ; use Coro ; use Coro::AIO ; use Coro::Channel ; use AnyEvent::Util ; use File::Temp ; use Encode ; #use Proc::FastSpawn; no warnings 'uninitialized' ; # --------------------------------------------------------------------------- has 'infile' => ( is => 'rw', isa => 'Str', lazy_build => 1, ) ; has 'outfile' => ( is => 'rw', isa => 'Str', lazy_build => 1, ) ; has 'checker_channel' => ( is => 'ro', isa => 'Coro::Channel', default => sub { Coro::Channel -> new } ) ; has 'checker2_channel' => ( is => 'ro', isa => 'Coro::Channel', default => sub { Coro::Channel -> new } ) ; # --------------------------------------------------------------------------- sub _build_infile { my ($fh, $filename) = File::Temp::tempfile(); close $fh ; return $filename ; } # --------------------------------------------------------------------------- sub _build_outfile { my ($fh, $filename) = File::Temp::tempfile(); close $fh ; return $filename ; } # --------------------------------------------------------------------------- sub check_perl_syntax { my ($self, $workspace, $uri, $text) = @_ ; $self -> checker_channel -> put ([$uri, $text]) ; } # --------------------------------------------------------------------------- sub run_win32 { my ($self, $text, $inc) = @_ ; return (0, undef, undef) ; # disable for now on windows my $infile = $self -> infile ; my $outfile = $self -> outfile ; print STDERR "infile=$infile outfile=$outfile\n" ; my $ifh = aio_open ($infile, IO::AIO::O_WRONLY | IO::AIO::O_TRUNC | IO::AIO::O_CREAT, 0600) or die "open $infile failed ($!)" ; aio_write ($ifh, undef, undef, $text, 0) ; aio_close ($ifh) ; print STDERR "run ", $self -> perlcmd . " -c @$inc $infile 2> $outfile", "\n" ; # use Win32::Process ; # my $cmd = $self -> perlcmd . " -c @$inc $infile" ; # print STDERR $cmd, "\n" ; # my $ProcessObj ; my $rc ; # Win32::Process::Create($ProcessObj, # $self -> perlcmd, # $cmd, # 0, # NORMAL_PRIORITY_CLASS, # "."); # print STDERR "wait\n" ; # $ProcessObj->Wait(5000) ; print STDERR "done\n" ; my $errout ; my $out ; aio_load ($outfile, $errout) ; print STDERR "errout = $errout\n" ; return ($rc, $out, $errout) ; } # --------------------------------------------------------------------------- sub run_system { my ($self, $text, $inc) = @_ ; my $infile = $self -> infile ; my $outfile = $self -> outfile ; local $SIG{CHLD} = 'DEFAULT' ; local $SIG{PIPE} = 'DEFAULT' ; print STDERR "infile=$infile outfile=$outfile\n" ; my $ifh = aio_open ($infile, IO::AIO::O_WRONLY | IO::AIO::O_TRUNC | IO::AIO::O_CREAT, 0600) or die "open $infile failed ($!)" ; aio_write ($ifh, undef, undef, $text, 0) ; aio_close ($ifh) ; print STDERR "run ", $self -> perlcmd . " -c @$inc $infile 2> $outfile", "\n" ; my $rc = system ($self -> perlcmd . " -c @$inc $infile 2> $outfile") ; print STDERR "done\n" ; my $errout ; my $out ; aio_load ($outfile, $errout) ; print STDERR "errout = $errout\n" ; return ($rc, $out, $errout) ; } # --------------------------------------------------------------------------- sub run_open3 { my ($self, $text, $inc) = @_ ; #return (0, undef, undef) ; my($wtr, $rdr, $err); require IPC::Open3 ; use Symbol 'gensym'; $err = gensym; $self -> logger ("open3\n") if ($Perl::LanguageServer::debug2) ; my $pid = IPC::Open3::open3($wtr, $rdr, $err, $self -> perlcmd, '-c', @$inc) or die "Cannot run " . $self -> perlcmd ; $self -> logger ("write start pid=$pid\n") if ($Perl::LanguageServer::debug2) ; syswrite ($wtr, $text . "\n__END__\n") ; $self -> logger ("close start\n") if ($Perl::LanguageServer::debug2) ; close ($wtr) ; $self -> logger ("write done\n") if ($Perl::LanguageServer::debug2) ; my $out ; my $errout = join ('', <$err>) ; close $err ; close $rdr ; $self -> logger ("closed\n") if ($Perl::LanguageServer::debug2) ; waitpid( $pid, 0 ); my $rc = $? ; return ($rc, $out, $errout) ; } # --------------------------------------------------------------------------- sub background_checker { my ($self, $server) = @_ ; async { my $channel1 = $self -> checker_channel ; my $channel2 = $self -> checker2_channel ; my %timer ; while (my $cmd = $channel1 -> get) { my ($uri, $text) = @$cmd ; $timer{$uri} = AnyEvent->timer (after => 1.5, cb => sub { delete $timer{$uri} ; $channel2 -> put($cmd) ; }) ; } } ; my $channel = $self -> checker2_channel ; while (my $cmd = $channel -> get) { my ($uri, $text) = @$cmd ; $text = eval { Encode::encode ('utf-8', $text) ; } ; $self -> logger ($@) if ($@) ; my $fn = $uri ; $fn =~ s/^file:\/\/// ; $fn = $self -> file_client2server ($fn) ; $text = "local \$0; BEGIN { \$0 = '$fn'; if (\$INC{'FindBin.pm'}) { FindBin->again(); } }\n# line 1 \"$fn\"\n" . $text; my $ret ; my $errout ; my $out ; my $inc = $self -> perlinc ; my @inc ; @inc = map { ('-I', $_)} @$inc if ($inc) ; my @syntax_options ; if ($self -> use_taint_for_syntax_check) { @syntax_options = ('-T') ; } $self -> logger ("start perl @syntax_options -c @inc for $uri\n") if ($Perl::LanguageServer::debug1) ; if ($^O =~ /Win/) { # ($ret, $out, $errout) = $self -> run_open3 ($text, \@inc) ; ($ret, $out, $errout) = $self -> run_win32 ($text, \@inc) ; } else { $ret = run_cmd ([$self -> perlcmd, @syntax_options, '-c', @inc], "<", \$text, ">", \$out, "2>", \$errout) -> recv ; } my $rc = $ret >> 8 ; $self -> logger ("perl -c rc=$rc out=$out errout=$errout\n") if ($Perl::LanguageServer::debug1) ; my @messages ; if ($rc != 0) { my $line ; my @lines = split /\n/, $errout ; my $lineno = 0 ; my $filename ; my $lastline = 1 ; my $msg ; my $severity = 1 ; foreach $line (@lines) { $line =~ s/\s*$// ; #print STDERR $line, "\n" ; next if ($line =~ /had compilation errors/) ; $filename = $1 if ($line =~ /at (.+?) line (\d+)[,.]/) ; #print STDERR "line = $lineno file=$filename fn=$fn\n" ; $filename ||= $fn ; $lineno = $1 if ($line =~ / line (\d+)[,.]/) ; $msg .= $line ; if ($lineno) { push @messages, [$filename, $lineno, $severity, $msg] if ($msg) ; $lastline = $lineno ; $lineno = 0 ; $msg = '' ; } } } $self -> add_diagnostic_messages ($server, $uri, 'perl syntax', \@messages) ; } } 1; __END__ sub xxxx { my $infile = $self -> infile ; my $outfile = $self -> outfile ; print STDERR "infile=$infile outfile=$outfile\n" ; my $ifh = aio_open ($infile, IO::AIO::O_WRONLY | IO::AIO::O_TRUNC | IO::AIO::O_CREAT, 0600) or die "open $infile failed ($!)" ; aio_write ($ifh, undef, undef, $text, 0) ; aio_close ($ifh) ; # my $oldstderr ; # open($oldstderr, ">&", \*STDERR) or die "Can't dup STDERR: $!"; # open(STDERR, '>', $outfile) or die "Can't redirect STDERR: $!"; # print STDERR "start\n" ; # my $pid = spawnp "perl", ["perl", "-c", $infile]; # open(STDERR, ">&", $oldstderr) or die "Can't dup \$oldstderr: $!"; #my $pid = spawnp "cmd", ["cmd", '/C', "perl -c $infile 2> $outfile"]; my $pid = spawnp $workspace -> perlcmd, [$workspace -> perlcmd, ] print STDERR "pid=$pid\n" ; my $w = AnyEvent->child (pid => $pid, cb => rouse_cb) ; my $ret = rouse_wait ; undef $w ; #Coro::AnyEvent::sleep (1) ; #print STDERR "wait\n" ; #waitpid ($pid, 0) ; #my $ret = $? ; my $rc = $ret >> 8; print STDERR "perl -c rc=$rc\n" ; #aio_slurp ($outfile, 0, 0, $errout) ; aio_load ($outfile, $errout) ; print STDERR "errout = $errout\n" ; #return ; #my ($rc, $diags) = rouse_wait ; my $diags = [] ; print STDERR "---perl -c rc=$rc\n" ; return if ($rc == 0) ; my $result = { method => 'textDocument/publishDiagnostics', params => { uri => $uri, diagnostics => $diags, }, } ; $self -> send_notification ($result) ; } # my $cv = run_cmd [$workspace -> perlcmd, '-c'], # # "<", \$text, # "2>", \$errout # ; # $cv->cb (sub # { # shift->recv and die "perl -c failed"; # print "-------->$errout\n"; # }); # return ; AnyEvent::Util::fork_call (sub { print STDERR "open3 start c $$\n" ; IO::AIO::reinit ; my($wtr, $rdr, $err); #return ; # use Symbol 'gensym'; $err = gensym; my $pid = open3($wtr, $rdr, $err, $workspace -> perlcmd, '-c') or die "Cannot run " . $workspace -> perlcmd ; #cede () ; print STDERR "write start pid=$pid\n" ; syswrite ($wtr, $text . "\n__END__\n") ; print STDERR "close start\n" ; close ($wtr) ; print STDERR "write done\n" ; #my $errout = unblock $err ; my @diags ; my $line ; # while ($line = $errout -> readline) while ($line = <$rdr>) { $line =~ s/\s*$// ; print STDERR $line, "\n" ; next if ($line =~ /had compilation errors/) ; my $lineno = 0 ; $lineno = $1 if ($line =~ / line (\d+),/) ; my $diag = { # range: Range; # severity?: number; # code?: number | string; # source?: string; # message: string; # relatedInformation?: DiagnosticRelatedInformation[]; range => { start => { line => $lineno-1, character => 0 }, end => { line => $lineno+0, character => 0 }}, message => $line, } ; push @diags, $diag ; } print STDERR "EOF\n" ; waitpid( $pid, 0 ); my $rc = $? >> 8; print STDERR "perl -c rc=$rc\n" ; return ($rc, \@diags) ; }, rouse_cb ) ; my ($rc, $diags) = rouse_wait ; print STDERR "---perl -c rc=$rc\n" ; return if ($rc == 0) ; my $result = { method => 'textDocument/publishDiagnostics', params => { uri => $uri, diagnostics => $diags, }, } ; $self -> send_notification ($result) ; } 1 ; Perl-LanguageServer-2.6.2/lib/Perl/LanguageServer/IO.pm0000644000000000000000000000655314420734115021272 0ustar rootrootpackage Perl::LanguageServer::IO ; use Moose::Role ; use Coro ; use Coro::AIO ; use Data::Dump qw{dump} ; no warnings 'uninitialized' ; has 'out_fh' => ( is => 'rw', #isa => 'Int', ) ; has 'in_fh' => ( is => 'rw', #isa => 'Int', ) ; # --------------------------------------------------------------------------- our $windows= ($^O =~ /Win/)?1:0 ; # --------------------------------------------------------------------------- sub _read { my ($self, $data, $length, $dataoffset, $fh, $readline) = @_ ; $fh ||= $self -> in_fh ; if (ref ($fh) =~ /^Coro::Handle/) { if ($readline) { $$data = $fh -> readline ; return length ($$data) ; } return $fh -> sysread ($$data, $length, $dataoffset) ; } if (!$windows || !ref $fh) { return aio_read ($fh, undef, $length, $$data, $dataoffset) ; } my $timeout = 0.01 ; my $s = IO::Select -> new (); $s -> add($fh) ; my @ready ; while (!(@ready = $s -> can_read (0))) { Coro::AnyEvent::sleep ($timeout) ; } $length = length ($$data) if (!defined ($length)) ; return sysread ($fh, $$data, $length, $dataoffset) ; } # --------------------------------------------------------------------------- sub _write { my ($self, $data, $length, $dataoffset) = @_ ; my $fh = $self -> out_fh ; if (ref ($fh) =~ /^Coro::Handle/) { return $fh -> syswrite ($data, $length, $dataoffset) ; } if (!$windows || !ref $fh) { return aio_write ($fh, undef, $length, $data, $dataoffset) ; } $length = length ($data) if (!defined ($length)) ; return syswrite ($fh, $data, $length, $dataoffset) ; } # --------------------------------------------------------------------------- sub run_async { my ($self, $cmd, $on_stdout, $on_stderr, $on_exit) = @_ ; $on_stdout ||= 'on_stdout' ; $on_stderr ||= 'on_stderr' ; $on_exit ||= 'on_exit' ; my($wtr, $rdr, $err); if ( ref($cmd) ) { $self -> logger ("start @$cmd\n") ; } else { $self -> logger ("start $cmd\n") ; } require IPC::Open3 ; require Symbol ; $err = Symbol::gensym () ; my $pid; if ( ref($cmd) ) { $pid = IPC::Open3::open3($wtr, $rdr, $err, @$cmd) or die "Cannot run @$cmd" ; } else { $pid = IPC::Open3::open3($wtr, $rdr, $err, $cmd) or die "Cannot run $cmd" ; } $self -> out_fh ($wtr) ; $self -> in_fh ($rdr) ; if ( ref($cmd) ) { $self -> logger ("@$cmd started\n") ; } else { $self -> logger ("$cmd started\n") ; } async { my $data ; while ($self -> _read (\$data, 8192)) { $self -> logger ("stdout ", $data, "\n") ; $self -> $on_stdout ($data) ; } waitpid( $pid, 0 ); $self -> logger ("@$cmd ended\n") ; Coro::cede_notself () ; $self -> $on_exit ($?) ; } ; async { my $data ; while ($self -> _read (\$data, 8192, undef, $err)) { $self -> logger ("stderr ", $data, "\n") ; $self -> $on_stderr ($data) ; } } ; return $pid ; } 1 ; Perl-LanguageServer-2.6.2/lib/Perl/LanguageServer/Req.pm0000644000000000000000000000142114370011436021475 0ustar rootrootpackage Perl::LanguageServer::Req ; use strict; use Moose ; no warnings 'uninitialized' ; # --------------------------------------------------------------------------- has 'id' => ( isa => 'Maybe[Str]', is => 'ro' ) ; has 'params' => ( isa => 'HashRef', is => 'ro' ) ; has 'cancel' => ( isa => 'Bool', is => 'rw', default => 0, ) ; has 'is_dap' => ( isa => 'Bool', is => 'rw', default => 0, ) ; has 'type' => ( isa => 'Str', is => 'rw', ) ; # --------------------------------------------------------------------------- sub cancel_req { my ($self) = @_ ; $self -> cancel (1) ; } # --------------------------------------------------------------------------- 1 ; Perl-LanguageServer-2.6.2/lib/Perl/LanguageServer/DebuggerInterface.pm0000644000000000000000000013265514456574413024347 0ustar rootroot# # We include DB package from perl core here, to be able to modify it... # package DB; # "private" globals my ($running, $ready, $deep, $usrctxt, $evalarg, @stack, @saved, @skippkg, @clients); my $preeval = {}; my $posteval = {}; my $ineval = {}; #### # # Globals - must be defined at startup so that clients can refer to # them right after a C # #### BEGIN { # these are hardcoded in perl source (some are magical) $DB::sub = ''; # name of current subroutine %DB::sub = (); # "filename:fromline-toline" for every known sub $DB::single = 0; # single-step flag (set it to 1 to enable stops in BEGIN/use) $DB::signal = 0; # signal flag (will cause a stop at the next line) $DB::trace = 0; # are we tracing through subroutine calls? @DB::args = (); # arguments of current subroutine or @ARGV array @DB::dbline = (); # list of lines in currently loaded file %DB::dbline = (); # actions in current file (keyed by line number) @DB::ret = (); # return value of last sub executed in list context $DB::ret = ''; # return value of last sub executed in scalar context # other "public" globals $DB::package = ''; # current package space $DB::filename = ''; # current filename $DB::subname = ''; # currently executing sub (fully qualified name) $DB::lineno = ''; # current line number $DB::VERSION = $DB::VERSION = '1.07'; # initialize private globals to avoid warnings $running = 1; # are we running, or are we stopped? @stack = (0); @clients = (); $deep = 1000; $ready = 0; @saved = (); @skippkg = (); $usrctxt = ''; $evalarg = ''; # scan args for stdin redirect for (my $i=0; $i <= $#ARGV; $i++) { if ($ARGV[$i] eq "<" && $i < $#ARGV) { # open stdin from file open STDIN, "<", $ARGV[$i+1] or die "open stdin"; # remove from ARGV splice @ARGV, $i, 2; } } } #### # entry point for all subroutine calls # sub sub { # this is important, othwise return values might be corrupted... return &$DB::sub if (!$DB::single) ; push(@stack, $DB::single); $DB::single &= 1; $DB::single |= 4 if $#stack == $deep; if ($DB::sub eq 'DESTROY' or substr($DB::sub, -9) eq '::DESTROY' or not defined wantarray) { &$DB::sub; $DB::single |= pop(@stack); $DB::ret = undef; } elsif (wantarray) { @DB::ret = &$DB::sub; $DB::single |= pop(@stack); @DB::ret; } else { $DB::ret = &$DB::sub; $DB::single |= pop(@stack); $DB::ret; } } #### # this is called by perl for every statement # sub DB { return unless $ready; &save; ($DB::package, $DB::filename, $DB::lineno) = caller; return if @skippkg and grep { $_ eq $DB::package } @skippkg; $usrctxt = "package $DB::package;"; # this won't let them modify, alas local(*DB::dbline) = "::_<$DB::filename"; my ($stop, $action); if (($stop,$action) = split(/\0/,$DB::dbline{$DB::lineno})) { if ($stop eq '1') { $DB::signal |= 1; } else { $stop = 0 unless $stop; # avoid un_init warning $evalarg = "\$DB::signal |= do { $stop; }"; &eval; $DB::dbline{$DB::lineno} =~ s/;9($|\0)/$1/; # clear any temp breakpt } } if ($DB::single || $DB::trace || $DB::signal) { $DB::subname = ($DB::sub =~ /\'|::/) ? $DB::sub : "${DB::package}::$DB::sub"; #'; DB->loadfile($DB::filename, $DB::lineno); } $evalarg = $action, &eval if $action; if ($DB::single || $DB::signal) { _outputall($#stack . " levels deep in subroutine calls.\n") if $DB::single & 4; $DB::single = 0; $DB::signal = 0; $running = 0; &eval if ($evalarg = DB->prestop); my $c; for $c (@clients) { # perform any client-specific prestop actions &eval if ($evalarg = $c->cprestop); # Now sit in an event loop until something sets $running do { $c->idle; # call client event loop; must not block if ($running == 2) { # client wants something eval-ed &eval if ($evalarg = $c->evalcode); $running = 0; } } until $running; # perform any client-specific poststop actions &eval if ($evalarg = $c->cpoststop); } &eval if ($evalarg = DB->poststop); } ($@, $!, $,, $/, $\, $^W) = @saved; (); } #### # this takes its argument via $evalarg to preserve current @_ # sub eval { ($@, $!, $,, $/, $\, $^W) = @saved; eval "$usrctxt $evalarg; &DB::save"; _outputall($@) if $@; } ############################################################################### # no compile-time subroutine call allowed before this point # ############################################################################### use strict; # this can run only after DB() and sub() are defined sub save { @saved = ($@, $!, $,, $/, $\, $^W); $, = ""; $/ = "\n"; $\ = ""; $^W = 0; } sub catch { for (@clients) { $_->awaken; } $DB::signal = 1; $ready = 1; } #### # # Client callable (read inheritable) methods defined after this point # #### sub register { my $s = shift; $s = _clientname($s) if ref($s); push @clients, $s; } sub done { my $s = shift; $s = _clientname($s) if ref($s); @clients = grep {$_ ne $s} @clients; $s->cleanup; # $running = 3 unless @clients; exit(0) unless @clients; } sub _clientname { my $name = shift; "$name" =~ /^(.+)=[A-Z]+\(.+\)$/; return $1; } sub next { my $s = shift; $DB::single = 2; $running = 1; } sub step { my $s = shift; $DB::single = 1; $running = 1; } sub cont { my $s = shift; my $i = shift; $s->set_tbreak($i) if $i; for ($i = 0; $i <= $#stack;) { $stack[$i++] &= ~1; } $DB::single = 0; $running = 1; } #### # XXX caller must experimentally determine $i (since it depends # on how many client call frames are between this call and the DB call). # Such is life. # sub ret { my $s = shift; my $i = shift; # how many levels to get to DB sub $i = 0 unless defined $i; $i -= $#stack-$i if ($#stack-$i < 0) ; $stack[$#stack-$i] |= 1; $DB::single = 0; $running = 1; } #### # XXX caller must experimentally determine $start (since it depends # on how many client call frames are between this call and the DB call). # Such is life. # sub backtrace { my $self = shift; my $start = shift; my($p,$f,$l,$s,$h,$w,$e,$r,$a, @a, @ret,$i); $start = 1 unless $start; for ($i = $start; ($p,$f,$l,$s,$h,$w,$e,$r) = caller($i); $i++) { @a = @DB::args; for (@a) { s/'/\\'/g; s/([^\0]*)/'$1'/ unless /^-?[\d.]+$/; s/([\200-\377])/sprintf("M-%c",ord($1)&0177)/eg; s/([\0-\37\177])/sprintf("^%c",ord($1)^64)/eg; } $w = $w ? '@ = ' : '$ = '; $a = $h ? '(' . join(', ', @a) . ')' : ''; $e =~ s/\n\s*\;\s*\Z// if $e; $e =~ s/[\\\']/\\$1/g if $e; if ($r) { $s = "require '$e'"; } elsif (defined $r) { $s = "eval '$e'"; } elsif ($s eq '(eval)') { $s = "eval {...}"; } $f = "file '$f'" unless $f eq '-e'; push @ret, "$w&$s$a from $f line $l"; last if $DB::signal; } return @ret; } sub _outputall { my $c; for $c (@clients) { $c->output(@_); } } sub trace_toggle { my $s = shift; $DB::trace = !$DB::trace; } #### # without args: returns all defined subroutine names # with subname args: returns a listref [file, start, end] # sub subs { my $s = shift; if (@_) { my(@ret) = (); while (@_) { my $name = shift; push @ret, [$DB::sub{$name} =~ /^(.*)\:(\d+)-(\d+)$/] if exists $DB::sub{$name}; } return @ret; } return keys %DB::sub; } #### # first argument is a filename whose subs will be returned # if a filename is not supplied, all subs in the current # filename are returned. # sub filesubs { my $s = shift; my $fname = shift; $fname = $DB::filename unless $fname; return grep { $DB::sub{$_} =~ /^$fname/ } keys %DB::sub; } #### # returns a list of all filenames that DB knows about # sub files { my $s = shift; my(@f) = grep(m|^_<|, keys %main::); return map { substr($_,2) } @f; } #### # returns reference to an array holding the lines in currently # loaded file # sub lines { my $s = shift; return \@DB::dbline; } #### # loadfile($file, $line) # sub loadfile { my $s = shift; my($file, $line) = @_; if (!defined $main::{'_<' . $file}) { my $try; if (($try) = grep(m|^_<.*$file|, keys %main::)) { $file = substr($try,2); } } if (defined($main::{'_<' . $file})) { my $c; # _outputall("Loading file $file.."); *DB::dbline = "::_<$file"; $DB::filename = $file; for $c (@clients) { # print "2 ", $file, '|', $line, "\n"; $c->showfile($file, $line); } return $file; } return undef; } sub lineevents { my $s = shift; my $fname = shift; my(%ret) = (); my $i; $fname = $DB::filename unless $fname; local(*DB::dbline) = "::_<$fname"; for ($i = 1; $i <= $#DB::dbline; $i++) { $ret{$i} = [$DB::dbline[$i], split(/\0/, $DB::dbline{$i})] if defined $DB::dbline{$i}; } return %ret; } sub set_break { my $s = shift; my $i = shift; my $cond = shift; $i ||= $DB::lineno; $cond ||= '1'; $i = _find_subline($i) if ($i =~ /\D/); $s->output("Subroutine not found.\n") unless $i; if ($i) { if ($DB::dbline[$i] == 0) { $s->output("Line $i not breakable.\n"); } else { $DB::dbline{$i} =~ s/^[^\0]*/$cond/; } } } sub set_tbreak { my $s = shift; my $i = shift; $i = _find_subline($i) if ($i =~ /\D/); $s->output("Subroutine not found.\n") unless $i; if ($i) { if ($DB::dbline[$i] == 0) { $s->output("Line $i not breakable.\n"); } else { $DB::dbline{$i} =~ s/($|\0)/;9$1/; # add one-time-only b.p. } } } sub _find_subline { my $name = shift; $name =~ s/\'/::/; $name = "${DB::package}\:\:" . $name if $name !~ /::/; $name = "main" . $name if substr($name,0,2) eq "::"; my($fname, $from, $to) = ($DB::sub{$name} =~ /^(.*):(\d+)-(\d+)$/); if ($from) { local *DB::dbline = "::_<$fname"; ++$from while $DB::dbline[$from] == 0 && $from < $to; return wantarray?($from, $name, $fname):$from; } return undef; } sub clr_breaks { my $s = shift; my $i; if (@_) { while (@_) { $i = shift; $i = _find_subline($i) if ($i =~ /\D/); $s->output("Subroutine not found.\n") unless $i; if (defined $DB::dbline{$i}) { $DB::dbline{$i} =~ s/^[^\0]+//; if ($DB::dbline{$i} =~ s/^\0?$//) { delete $DB::dbline{$i}; } } } } else { for ($i = 1; $i <= $#DB::dbline ; $i++) { if (defined $DB::dbline{$i}) { $DB::dbline{$i} =~ s/^[^\0]+//; if ($DB::dbline{$i} =~ s/^\0?$//) { delete $DB::dbline{$i}; } } } } } sub set_action { my $s = shift; my $i = shift; my $act = shift; $i = _find_subline($i) if ($i =~ /\D/); $s->output("Subroutine not found.\n") unless $i; if ($i) { if ($DB::dbline[$i] == 0) { $s->output("Line $i not actionable.\n"); } else { $DB::dbline{$i} =~ s/\0[^\0]*//; $DB::dbline{$i} .= "\0" . $act; } } } sub clr_actions { my $s = shift; my $i; if (@_) { while (@_) { my $i = shift; $i = _find_subline($i) if ($i =~ /\D/); $s->output("Subroutine not found.\n") unless $i; if ($i && $DB::dbline[$i] != 0) { $DB::dbline{$i} =~ s/\0[^\0]*//; delete $DB::dbline{$i} if $DB::dbline{$i} =~ s/^\0?$//; } } } else { for ($i = 1; $i <= $#DB::dbline ; $i++) { if (defined $DB::dbline{$i}) { $DB::dbline{$i} =~ s/\0[^\0]*//; delete $DB::dbline{$i} if $DB::dbline{$i} =~ s/^\0?$//; } } } } sub prestop { my ($client, $val) = @_; return defined($val) ? $preeval->{$client} = $val : $preeval->{$client}; } sub poststop { my ($client, $val) = @_; return defined($val) ? $posteval->{$client} = $val : $posteval->{$client}; } # # "pure virtual" methods # # client-specific pre/post-stop actions. sub cprestop {} sub cpoststop {} # client complete startup sub awaken {} sub skippkg { my $s = shift; push @skippkg, @_ if @_; } sub evalcode { my ($client, $val) = @_; if (defined $val) { $running = 2; # hand over to DB() to evaluate in its context $ineval->{$client} = $val; } return $ineval->{$client}; } sub ready { my $s = shift; return $ready = 1; } # stubs sub init {} sub stop {} sub idle {} sub cleanup {} sub output {} # # client init # for (@clients) { $_->init } $SIG{'INT'} = \&DB::catch; # disable this if stepping through END blocks is desired # (looks scary and deconstructivist with Swat) END { $ready = 0 } ############################################################################## package Perl::LanguageServer::DebuggerInterface ; #use DB; our @ISA = qw(DB); use strict ; use IO::Socket ; use JSON ; use PadWalker ; use Scalar::Util qw{blessed reftype looks_like_number}; use Hash::SafeKeys; #use Data::Dump qw{pp} ; use File::Basename ; use vars qw{@dbline %dbline $dbline} ; our $max_display = 5 ; our $debug = 0 ; our $session = $ENV{PLSDI_SESSION} || 1 ; our $socket ; our $json = JSON -> new -> utf8(1) -> ascii(1) ; our @evalresult ; our %postponed_breakpoints ; our $breakpoint_id = 1 ; our $loaded = 0 ; our $break_reason ; our $refresh ; __PACKAGE__ -> register ; __PACKAGE__ -> init ; # --------------------------------------------------------------------------- sub logger { my $class = shift ; print STDERR @_ ; } # --------------------------------------------------------------------------- use constant SPECIALS => { _ => 1, INC => 1, ARGV => 1, ENV => 1, ARGVOUT => 1, SIG => 1, STDIN => 1, STDOUT => 1, STDERR => 1, stdin => 1, stdout => 1, stderr => 1} ; use vars qw{%entry @entry $entry %stab} ; # --------------------------------------------------------------------------- sub get_globals { my ($self, $package) = @_ ; my %vars ; my $specials = $package?0:1 ; $package ||= 'main' ; $package .= "::" unless $package =~ /::$/; no strict ; *stab = *{"main::"}; while ($package =~ /(\w+?::)/g) { *stab = ${stab}{$1}; } use strict ; my $key ; my $val ; while (($key, $val) = each (%stab)) { next if ($key eq '_') ; next if ($key =~ /^_ {$key} || ($key !~ /^[a-zA-Z_]/))) ; next if ($specials && (!SPECIALS -> {$key} && ($key =~ /^[a-zA-Z_]/))) ; local(*entry) = $val; $key =~ s/([\0-\x1f])/'^'.chr(ord($1)+0x40)/eg ; $vars{"\$$key"} = [\$entry, 'eg:\\$' . $package . $key] if (defined $entry) ; $vars{"\@$key"} = [\@entry, 'eg:\\@' . $package . $key] if (@entry) ; $vars{"\%$key"} = [\%entry, 'eg:\\%' . $package . $key] if (%entry) ; #$vars{"\&$key"} = \&entry if (defined &entry) ; my $fileno; $vars{"Handle:$key"} = [\"fileno=$fileno"] if (defined ($fileno = eval{fileno(*entry)})) ; } return \%vars ; } # --------------------------------------------------------------------------- sub get_var_eval { my ($self, $name, $varsrc, $prefix) = @_ ; # use Data::Dump qw{pp} ; # print STDERR "eval ", pp([$name, $varsrc]), "\n" ; my %vars ; $prefix ||= $varsrc?'el:':'eg:' ; my $refexpr ; my $pre ; my $post ; $refexpr = $name ; my $ref = eval ($refexpr) ; if ($@) { $vars{'ERROR'} = [$@] ; } #print STDERR "name=$name ref=$ref refref=", ref ($ref), "reftype=", reftype ($ref), "\n", pp($ref), "\n" ; if (ref ($ref) eq 'REF') { $ref = $$ref ; #print STDERR "deref ----> ref val=$refexpr ref=$ref refref=", ref ($ref), "reftype=", reftype ($ref), "\n" ; $pre = '${' ; $post = '}' ; } if (reftype ($ref) eq 'ARRAY') { my $n = 0 ; foreach my $entry (@$ref) { $vars{"$n"} = [\$entry, $prefix . $pre . '(' . $refexpr . ')' . $post . '->[' . $n . ']' ] ; $n++ ; } } elsif (reftype ($ref) eq 'HASH') { my $iterator = Hash::SafeKeys::save_iterator_state($ref); foreach my $entry (sort keys %$ref) { $vars{"$entry"} = [\$ref -> {$entry}, $prefix . $pre . '(' . $refexpr . ')' . $post . "->{'" . $entry . "'}" ] ; } Hash::SafeKeys::restore_iterator_state($ref, $iterator); } else { $vars{'$'} = [$ref] ; } return \%vars ; } # --------------------------------------------------------------------------- sub get_arguments { my ($self, $frame) = @_ ; my $vars ; my %varsrc ; eval { my @args = _get_caller_args ($frame+2) ; $varsrc{"\@_"} = [\@args, "ea:\$varsrc->{'\@_'}[0]"] ; $varsrc{"\@ARGV"} = [\@main::ARGV, 'eg:\\@main::ARGV'] ; } ; $self -> logger ($@) if ($@) ; return (\%varsrc) ; } # --------------------------------------------------------------------------- sub get_locals { my ($self, $frame) = @_ ; my $vars ; my %varsrc ; eval { $vars = PadWalker::peek_my ($frame) ; foreach my $var (keys %$vars) { $varsrc{$var} = [ $vars->{$var}, "el:\$varsrc->{'$var'}" ] ; } } ; $self -> logger ($@) if ($@) ; return (\%varsrc, $vars) ; } # --------------------------------------------------------------------------- sub _get_caller_args { my ($caller) = @_ ; local @DB::args ; my @caller_args ; { package DB; my @call_info = caller ($caller) ; #use Data::Dump qw{pp} ; #print STDERR "db::args after caller $caller ", pp(\@DB::args), "\n" ; @caller_args = @DB::args ; } return @caller_args ; } # --------------------------------------------------------------------------- sub _eval_replace { my ($___di_vars, $___di_sigil, $___di_var, $___di_suffix, $___di_frame) = @_ ; #print STDERR "sigil = $___di_sigil var = $___di_var suffix = $___di_suffix\n" ; if ($___di_var eq '_') { my @args = _get_caller_args ($___di_frame + 3) ; $___di_vars -> {'@_'} = \@args ; } #use Data::Dump qw{pp} ; #print STDERR "vars ", pp ($___di_vars),"\n" ; if ($___di_suffix) { return "\$___di_vars->{'\%$___di_var'}{" if ($___di_suffix eq '{' && exists $___di_vars->{"\%$___di_var"}) ; return "\$___di_vars->{'\@$___di_var'}[" if (exists $___di_vars->{"\@$___di_var"}); } else { return "\$\#\{\$___di_vars->{'\@$1'}}" if (($___di_var =~ /^#(.+)/) && exists $___di_vars->{"\@$1"}) ; #print STDERR "v = $___di_var 1 = $1\n" ; return "$___di_sigil\{\$___di_vars->{'$___di_sigil$___di_var'}}" if (exists $___di_vars->{"$___di_sigil$___di_var"}) ; } return "$___di_sigil$___di_var$___di_suffix" ; } # --------------------------------------------------------------------------- sub get_eval_result { my ($self, $frame, $package, $expression) = @_; my $___di_vars = PadWalker::peek_my ($frame) ; $expression =~ s/([\%\@\$])(#?\w+)\s*([\[\{])?/_eval_replace($___di_vars, $1, $2, $3, $frame)/eg ; my $code = "package $package ; no strict ; $expression"; my %vars ; #print STDERR "frame=$frame code = $code\n" ; my @result = eval $code; if ($@) { $vars{'ERROR'} = [$@] ; } else { if (@result < 2) { if (ref ($result[0]) eq 'REF') { push @evalresult, $result[0] ; } else { push @evalresult, \$result[0] ; } } elsif ($expression =~ /^\s*\\?\s*\%/) { push @evalresult, { @result } ; } else { push @evalresult, \@result ; } $vars{'eval'} = [$evalresult[-1], 'eg:$Perl::LanguageServer::DebuggerInterface::evalresult[' . $#evalresult . ']'] ; } return \%vars ; } # --------------------------------------------------------------------------- sub get_scalar { my $ret = eval { my ($self, $val) = @_ ; return 'undef' if (!defined ($val)) ; my $obj = '' ; $obj = blessed ($val) . ' ' if (blessed ($val)) ; return $obj . '[..]' if (ref ($val) eq 'ARRAY') ; return $obj . '{..}' if (ref ($val) eq 'HASH') ; my $isnum = looks_like_number ($val); $obj . ($isnum?$val:"'$val'") ; } ; return $@ if ($@) ; return $ret ; } # --------------------------------------------------------------------------- sub get_vars { my ($self, $varsrc, $vars, $array) = @_ ; foreach my $k (sort { $array?$a <=> $b:$a cmp $b } keys %$varsrc) { my $key = $k ; my $val = $varsrc -> {$k}[0] ; my $ref = $varsrc -> {$k}[1] ; $key =~ s/([\0-\x1f])/'^'.chr(ord($1)+0x40)/eg ; #print STDERR "k=$k val=$val ref=$ref refref=", ref ($val), "reftype=", reftype ($ref), "\n" ; if (ref ($val) eq 'REF') { $val = $$val ; #print STDERR "deref ----> ref val=$val ref=$ref refref=", ref ($val), "reftype=", reftype ($ref), "\n" ; } my $obj = '' ; $obj = blessed ($val) . ' ' if (blessed ($val)) ; if (reftype ($val) eq 'SCALAR') { push @$vars, { name => $key, value => $obj . $self -> get_scalar ($$val), type => 'Scalar', } ; } if (reftype ($val) eq 'ARRAY') { my $display = $obj . '[' ; my $n = 1 ; foreach (@$val) { $display .= ',' if ($n > 1) ; $display .= $self -> get_scalar ($_) ; if ($n++ >= $max_display) { $display .= ',...' ; last ; } } $display .= ']' ; push @$vars, { name => $key, value => $display, type => 'Array', var_ref => $ref, indexedVariables => scalar (@$val), } ; } if (reftype ($val) eq 'HASH') { my $display = $obj . '{' ; my $n = 1 ; my $iterator = Hash::SafeKeys::save_iterator_state($val); foreach (sort keys %$val) { $display .= ',' if ($n > 1) ; $display .= "$_=>" . $self -> get_scalar ($val->{$_}) ; if ($n++ >= $max_display / 2) { $display .= ',...' ; last ; } } $display .= '}' ; push @$vars, { name => $key, value => $display, type => 'Hash', var_ref => $ref, namedVariables => scalar (keys %$val), } ; Hash::SafeKeys::restore_iterator_state($val, $iterator); } if ($key =~ /^Handle/) { push @$vars, { name => $key, value => $$val, type => 'Filehandle', } ; } } } # --------------------------------------------------------------------------- sub get_varsrc { my ($class, $frame_ref, $package, $type) = @_ ; my @vars ; my $varsrc ; if ($type eq 'l') { ($varsrc) = $class -> get_locals($frame_ref+3) ; } elsif ($type eq 'a') { ($varsrc) = $class -> get_arguments($frame_ref+3) ; } elsif ($type eq 'g') { $varsrc = $class -> get_globals($package) ; } elsif ($type eq 's') { $varsrc = $class -> get_globals() ; } elsif ($type =~ /^eg:(.+)/) { $varsrc = $class -> get_var_eval ($1) ; } elsif ($type =~ /^el:(.+)/) { my $name = $1 ; my ($dummy, $varlocal) = $class -> get_locals($frame_ref+3) ; $varsrc = $class -> get_var_eval ($name, $varlocal) ; } elsif ($type =~ /^ea:(.+)/) { my $name = $1 ; my ($args, $varlocal) = $class -> get_arguments($frame_ref+3) ; $varsrc = $class -> get_var_eval ($name, $args, 'ea:') ; } use Data::Dump qw{pp} ; #print STDERR "vars ", pp ($varsrc),"\n" ; return $varsrc ; } # --------------------------------------------------------------------------- sub req_vars { my ($class, $params, $recurse) = @_ ; my $thread_ref = $params -> {thread_ref} ; my $tid = defined ($Coro::current)?$Coro::current+0:1 ; if ($thread_ref != $tid && !$recurse && ($params -> {type} !~ /^eg:/)) { my $coro ; $coro = $class -> find_coro ($thread_ref) ; return { variables => [] } if (!$coro) ; my $ret ; $coro -> call (sub { $ret = $class -> req_vars ($params, $recurse + 1) ; }) ; return $ret ; } my $frame_ref = $params -> {frame_ref} - $recurse ; my $package = $params -> {'package'} ; my $type = $params -> {type} ; my $filter = $params -> {filter} ; my @vars ; my $varsrc = $class -> get_varsrc ($frame_ref, $package, $type) ; eval { $class -> get_vars ($varsrc, \@vars, $filter) ; } ; $class -> logger ($@) if ($@) ; return { variables => \@vars } ; } # --------------------------------------------------------------------------- sub _set_var_expr { my ($class, $type, $setvar, $expr_ref) = @_ ; if (!$type) { if ($setvar) { $$expr_ref = $setvar . '=' . $$expr_ref ; } return ; } my $refexpr ; if ($type =~ /^eg:(.+)/) { $refexpr = $1 ; my $ref = eval ($refexpr) ; return { name => "ERROR", value => $@, } if ($@) ; if (reftype ($ref) eq 'ARRAY') { $refexpr .= '[' . $setvar . ']' ; } elsif (reftype ($ref) eq 'HASH') { $refexpr .= '{' . $setvar . '}' ; } elsif (reftype ($ref) eq 'SCALAR') { $refexpr = '${' . $refexpr . '}' ; } else { return { name => "ERROR", value => "Cannot set variable if reference is of type " . reftype ($ref) , } ; } } else { return { name => "ERROR", value => "Invalid type: $type", } ; } $$expr_ref = $refexpr . '=' . $$expr_ref ; return ; } # --------------------------------------------------------------------------- sub req_setvar { my ($class, $params) = @_ ; my $thread_ref = $params -> {thread_ref} ; my $tid = defined ($Coro::current)?$Coro::current+0:1 ; return undef if ($thread_ref != $tid) ; my $frame_ref = $params -> {frame_ref} ; my $package = $params -> {'package'} ; my $expression = $params -> {'expression'} ; my $setvar = $params -> {'setvar'} ; my $type = $params -> {'type'} ; my @vars ; my $resultsrc ; my $varref ; my $varsrc = $class -> get_varsrc ($frame_ref, $package, $type) ; if (!exists $varsrc -> {$setvar}) { return { name => "ERROR", value => "unknown variable: $setvar", } ; } $varref = $varsrc -> {$setvar}[0] ; eval { $resultsrc = $class -> get_eval_result ($frame_ref+2, $package, $expression) ; $$varref = ${$resultsrc -> {eval}[0]} ; } ; return { name => "ERROR", value => $@, } if ($@) ; return { name => $setvar, value => "$$varref", } ; } # --------------------------------------------------------------------------- sub req_evaluate { my ($class, $params, $recurse) = @_ ; return undef if ($params -> {'context'} eq 'hover' && ($params -> {'expression'} !~ /^\s*\\?[\$\@\%]/)) ; my $thread_ref = $params -> {thread_ref} ; my $tid = defined ($Coro::current)?$Coro::current+0:1 ; if ($thread_ref != $tid && !$recurse) { my $coro ; $coro = $class -> find_coro ($thread_ref) ; return undef if (!$coro) ; my $ret ; $coro -> call (sub { $ret = $class -> req_evaluate ($params, $recurse + 1) ; }) ; return $ret ; } my $frame_ref = $params -> {frame_ref} - $recurse ; my $package = $params -> {'package'} ; my $expression = $params -> {'expression'} ; my @vars ; my $varsrc ; eval { $varsrc = $class -> get_eval_result ($frame_ref+2, $package, $expression) ; $class -> get_vars ($varsrc, \@vars) ; } ; return { name => "ERROR", value => $@, } if ($@) ; return $vars[0] ; } # --------------------------------------------------------------------------- sub req_threads { my @threads ; if (defined &Coro::State::list) { foreach my $coro (Coro::State::list()) { push @threads, { name => $coro->debug_desc, thread_ref => $coro+0, } ; } } else { @threads = { thread_ref => 1, name => 'single'} ; } return { threads => \@threads } ; } # --------------------------------------------------------------------------- sub find_coro { my ($class, $pid) = @_; return if (!defined &Coro::State::list) ; if (my ($coro) = grep ($_ == $pid, Coro::State::list())) { return $coro ; } else { $class -> logger ("$pid: no such coroutine\n") ; } return ; } # --------------------------------------------------------------------------- sub req_stack { my ($class, $params, $recurse) = @_ ; my $thread_ref = $params -> {thread_ref} ; my $tid = defined ($Coro::current)?$Coro::current+0:1 ; if ($thread_ref != $tid && !$recurse) { my $coro ; $coro = $class -> find_coro ($thread_ref) ; return { stackFrames => [] } if (!$coro) ; my $ret ; $coro -> call (sub { $ret = $class -> req_stack ($params, 1) ; }) ; return $ret ; } my $levels = $params -> {levels} || 999 ; my $start_frame = $params -> {start} || 0 ; $start_frame += 3 ; my @stack ; { package DB; my $i = 0 ; my @frames ; while ((my @call_info = caller($i++))) { my $sub = $call_info[3] ; push @frames, \@call_info ; $frames[-2][3] = $sub if (@frames > 1); } $frames[-1][3] = '
' if (@frames > 0); my $n = @frames + 1 ; $i = $n ; my $j = -1 ; while (my $frame = shift @frames) { $i-- ; $j++ ; next if ($start_frame-- > 0) ; last if ($levels-- <= 0) ; my ($package, $filename, $line, $subroutine, $hasargs) = @$frame ; my $sub_name = $subroutine ; $sub_name = $1 if ($sub_name =~ /.+::(.+?)$/) ; my $frame = { frame_ref => $j, name => $sub_name, source => { path => $filename }, line => $line, column => 1, #moduleId => $package, 'package' => $package, } ; $j-- if ($sub_name eq '(eval)') ; push @stack, $frame ; } } return { stackFrames => \@stack } ; } # --------------------------------------------------------------------------- sub _set_breakpoint { my ($class, $location, $condition) = @_ ; $condition ||= '1'; my $subname ; my $filename ; ($location, $subname, $filename) = DB::_find_subline($location) if ($location =~ /\D/); return (0, "Subroutine not found.") unless $location ; return (0) if (!$location) ; local *dbline = "::_<$filename" if ($filename) ; for (my $line = $location; $line <= $location + 10 && $location < @dbline; $line++) { if ($dbline[$line] != 0) { $dbline{$line+0} =~ s/^[^\0]*/$condition/; return (1, undef, $line, $filename) ; } } return (0, "Line $location for sub $subname is not breakable.") if ($subname) ; return (0, "Line $location is not breakable.") ; } # --------------------------------------------------------------------------- # abs path no dereference # copied from package Cwd::Ext and added directory argument sub abs_path_nd { my $abs_path = shift; my $dir = shift ; return $abs_path if $abs_path=~m{^/$}; unless( $abs_path=~/^\// ){ if ($dir) { $abs_path = $dir."/$abs_path"; } else { require Cwd; $abs_path = Cwd::cwd()."/$abs_path"; } } my @elems = split m{/}, $abs_path; my $ptr = 1; while($ptr <= $#elems){ if($elems[$ptr] eq '' ){ splice @elems, $ptr, 1; } elsif($elems[$ptr] eq '.' ){ splice @elems, $ptr, 1; } elsif($elems[$ptr] eq '..' ){ if($ptr < 2){ splice @elems, $ptr, 1; } else { $ptr--; splice @elems, $ptr, 2; } } else { $ptr++; } } $#elems ? join q{/}, @elems : q{/}; } # --------------------------------------------------------------------------- sub req_breakpoint { my ($class, $params) = @_ ; my $breakpoints = $params -> {breakpoints} ; my $filename = $params -> {filename} ; my $real_filename = $params -> {dbg_filename} || $filename ; Class::Refresh -> refresh if ($refresh) ; if ($filename) { my %seen ; while (!defined $main::{'_<' . $real_filename} && -l $real_filename) { my $dir = File::Basename::dirname ($real_filename) ; $real_filename = readlink ($real_filename) ; last if (!$real_filename) ; $real_filename = abs_path_nd ($real_filename, $dir) ; last if ($seen{$real_filename}++) ; } if (!defined $main::{'_<' . $real_filename}) { $postponed_breakpoints{$filename} = $breakpoints ; foreach my $bp (@$breakpoints) { $bp -> [6] = $breakpoint_id++ ; } return { breakpoints => $breakpoints } } } local *dbline = "::_<$real_filename" if ($real_filename) ; if ($real_filename) { # Switch the magical hash temporarily. local *DB::dbline = "::_<$real_filename"; $class -> clr_breaks () ; $class -> clr_actions () ; } foreach my $bp (@$breakpoints) { my $line = $bp -> [0] ; my $condition = $bp -> [1] ; ($bp -> [2], $bp -> [3], $bp -> [4], $bp -> [5]) = $class -> _set_breakpoint ($line, $condition) ; $bp -> [5] = $filename if ($filename) ; } return { breakpoints_set => 1, breakpoints => $breakpoints, ($filename ne $real_filename?(real_filename => $real_filename, req_filename => $filename):()) }; } # --------------------------------------------------------------------------- package DB { use vars qw{@dbline %dbline $dbline} ; sub postponed { my ($arg) = @_ ; return if (!$loaded) ; # If this is a subroutine... if (ref(\$arg) ne 'GLOB') { return ; } # Not a subroutine. Deal with the file. local *dbline = $arg ; my $filename = $dbline; my %seen ; my $pp_filename = $filename ; while (!exists $postponed_breakpoints{$pp_filename} && -l $pp_filename) { my $dir = File::Basename::dirname ($pp_filename) ; $pp_filename = readlink ($pp_filename) ; last if (!$pp_filename) ; $pp_filename = Perl::LanguageServer::DebuggerInterface::abs_path_nd ($pp_filename, $dir) ; last if ($seen{$pp_filename}++) ; } #Perl::LanguageServer::DebuggerInterface -> _send ({ command => 'di_loadedfile', arguments => { session_id => $session, reason => 'new', source => { path => $filename}}}) ; if (exists $postponed_breakpoints{$pp_filename}) { my $ret = Perl::LanguageServer::DebuggerInterface -> req_breakpoint ({ breakpoints => $postponed_breakpoints{$pp_filename}, filename => $pp_filename, dbg_filename => $filename }) ; if ($ret -> {breakpoints_set}) { delete $postponed_breakpoints{$pp_filename} ; Perl::LanguageServer::DebuggerInterface -> _send ({ command => 'di_breakpoints', arguments => { session_id => $session, %$ret}}) ; } } } } # --------------------------------------------------------------------------- sub req_source { my ($class, $params) = @_ ; my $filename = $params -> {filename} ; my $source = join("", @{$main::{'_<'.$filename}}); $source =~ s/\n;$//; return { content => $source }; } # --------------------------------------------------------------------------- sub req_can_break { my ($class, $params) = @_ ; my $line = $params -> {line} ; my $end_line = $params -> {end_line} || $line ; my $filename = $params -> {filename} ; my $real_filename = $filename ; my %seen ; while (!defined $main::{'_<' . $real_filename} && -l $real_filename) { my $dir = File::Basename::dirname ($real_filename) ; $real_filename = readlink ($real_filename) ; last if (!$real_filename) ; $real_filename = abs_path_nd ($real_filename, $dir) ; last if ($seen{$real_filename}++) ; } return { breakpoints => [] } if (!defined $main::{'_<' . $real_filename}) ; Class::Refresh -> refresh if ($refresh) ; # Switch the magical hash temporarily. local *dbline = "::_<$real_filename"; my @bp ; for (my $i = $line; $i <= $end_line; $i++) { if ($dbline[$line] != 0) { push @bp, { line => $line } ; } } return { breakpoints => \@bp }; } # --------------------------------------------------------------------------- sub req_continue { my ($class, $params) = @_ ; Class::Refresh -> refresh if ($refresh) ; @evalresult = () ; $class -> cont ; return ; } # --------------------------------------------------------------------------- sub req_step_in { my ($class, $params) = @_ ; Class::Refresh -> refresh if ($refresh) ; @evalresult = () ; $class -> step ; return ; } # --------------------------------------------------------------------------- sub req_step_out { my ($class, $params) = @_ ; Class::Refresh -> refresh if ($refresh) ; @evalresult = () ; $class -> ret (2) ; return ; } # --------------------------------------------------------------------------- sub req_next { my ($class, $params) = @_ ; Class::Refresh -> refresh if ($refresh) ; @evalresult = () ; $class -> next ; return ; } # --------------------------------------------------------------------------- sub _send { my ($class, $result) = @_ ; $result -> {type} = 'dbgint' ; my $outdata = $json -> encode ($result) ; use bytes ; my $len = length($outdata) ; my $wrdata = "Content-Length: $len\r\nContent-Type: application/vscode-jsonrpc; charset=utf-8\r\n\r\n$outdata" ; $socket -> syswrite ($wrdata) ; if ($debug) { $wrdata =~ s/\r//g ; $class -> logger ($wrdata, "\n") ; } } # --------------------------------------------------------------------------- sub _recv { my ($class) = @_ ; $class -> logger ("wait for input\n") if ($debug) ; my $line ; my $cnt ; my $buffer ; my $data ; my %header ; header: while (1) { $cnt = sysread ($socket, $buffer, 8192, length ($buffer)) ; die "read_error reading headers ($!)" if ($cnt < 0) ; return if ($cnt == 0) ; while ($buffer =~ s/^(.*?)\R//) { $line = $1 ; $class -> logger ("line=<$line>\n") if ($debug) ; last header if ($line eq '') ; $header{$1} = $2 if ($line =~ /(.+?):\s*(.+)/) ; } } my $len = $header{'Content-Length'} ; my $data ; $class -> logger ("len=$len len buffer=", length ($buffer), "\n") if ($debug) ; while ($len > length ($buffer)) { $cnt = sysread ($socket, $buffer, $len - length ($buffer), length ($buffer)) ; die "read_error reading data ($!)" if ($cnt < 0) ; return if ($cnt == 0) ; } if ($len == length ($buffer)) { $data = $buffer ; $buffer = '' ; } elsif ($len < length ($buffer)) { $data = substr ($buffer, 0, $len) ; $buffer = substr ($buffer, $len) ; } else { die "to few data bytes" ; } $class -> logger ("read data=", $data, "\n") if ($debug) ; $class -> logger ("read header=", "%header", "\n") if ($debug) ; my $cmddata = $json -> decode ($data) ; my $cmd = 'req_' . $cmddata -> {command} ; if ($class -> can ($cmd)) { my $result = $class -> $cmd ($cmddata) ; $class -> _send ({ command => 'di_response', seq => $cmddata -> {seq}, arguments => $result}) ; return ; } die "unknown cmd $cmd" ; } # --------------------------------------------------------------------------- sub awaken { my ($class) = @_ ; $class -> logger ("enter awaken\n") if ($debug) ; $break_reason = 'pause' ; #$class -> _send ({ command => 'di_break', arguments => { session_id => $session, reason => 'pause'}}) ; } # --------------------------------------------------------------------------- sub init { my ($class) = @_ ; $class -> logger ("enter init\n") if ($debug) ; $refresh = ($ENV{PLSDI_OPTIONS} =~ /reload_modules/)?1:0 ; if ($refresh) { require Class::Refresh ; Class::Refresh -> refresh ; } my $remote ; my $port ; ($remote, $port) = split /:/, $ENV{PLSDI_REMOTE} ; if ($remote =~ m/^([0-9.]+)$/) { $remote = $1; # untaint } if ($port =~ m/^(\d+)$/) { $port = $1; # untaint } $socket = IO::Socket::INET->new(PeerAddr => $remote, PeerPort => $port, Proto => 'tcp') or die "Cannot connect to $remote:$port ($!)"; $class -> ready (1) ; } # --------------------------------------------------------------------------- sub stop { my ($class) = @_ ; $class -> logger ("enter stop @_\n") if ($debug) ; } # --------------------------------------------------------------------------- sub idle { my ($class) = @_ ; $class -> logger ("enter idle @_\n") if ($debug) ; my $cmd = $class -> _recv () ; } # --------------------------------------------------------------------------- sub cleanup { my ($class) = @_ ; $class -> logger ("enter cleanup @_\n") if ($debug) ; } # --------------------------------------------------------------------------- sub output { my ($class) = @_ ; $class -> logger ("enter output @_\n") if ($debug) ; } # --------------------------------------------------------------------------- sub showfile { my ($class, $filename, $line) = @_ ; $class -> logger ("enter showfile @_\n") if ($debug) ; #$class -> _send ({ command => 'di_showfile', arguments => { session_id => $session, reason => 'new', source => { path => $filename}}}) ; } # --------------------------------------------------------------------------- sub evalcode { my ($class) = @_ ; $class -> logger ("enter evalcode @_\n") if ($debug) ; } # --------------------------------------------------------------------------- sub cprestop { my ($class) = @_ ; $class -> logger ("enter cprestop @_\n") if ($debug) ; @evalresult = () ; my $tid = defined ($Coro::current)?$Coro::current+0:1 ; $class -> _send ({ command => 'di_break', arguments => { thread_ref => $tid, session_id => $session, ($break_reason?(reason => $break_reason):()), }}) ; $break_reason = undef ; } # --------------------------------------------------------------------------- sub cpoststop { my ($class) = @_ ; $class -> logger ("enter cpoststop @_\n") if ($debug) ; } # --------------------------------------------------------------------------- $loaded = 1 ; 1 ; Perl-LanguageServer-2.6.2/META.yml0000644000000000000000000000170114541561342015306 0ustar rootroot--- abstract: 'Language Server and Debug Protocol Adapter for Perl' author: - 'grichter ' build_requires: Test::More: '0' configure_requires: ExtUtils::MakeMaker: '0' dynamic_config: 1 generated_by: 'ExtUtils::MakeMaker version 7.34, CPAN::Meta::Converter version 2.150010' license: artistic_2 meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: '1.4' name: Perl-LanguageServer no_index: directory: - t - inc requires: AnyEvent: '0' AnyEvent::AIO: '0' Class::Refresh: '0' Compiler::Lexer: '0.23' Coro: '0' Data::Dump: '0' Encode::Locale: '0' Hash::SafeKeys: '0' IO::AIO: '0' JSON: '0' Moose: '0' PadWalker: '0' Scalar::Util: '0' perl: '5.016' resources: bugtracker: https://github.com/richterger/Perl-LanguageServer/issues repository: https://github.com/richterger/Perl-LanguageServer.git version: v2.6.2 x_serialization_backend: 'CPAN::Meta::YAML version 0.018'