From 131539d461786d475f0b14a66e1b8ff746188ca1 Mon Sep 17 00:00:00 2001 From: Dmitry Moskowski Date: Sun, 31 May 2026 00:48:16 +0000 Subject: [PATCH 1/2] server: resolve Lazarus package links from config Load Lazarus package links from packagefiles.xml and global link files when configuring project search paths. Prefering explicit config package links over discovered and global links. Resolve package paths relative to their config or package location, and expand Lazarus/FPC/target/project macros while preserving unknown macros as-is. Add LazConfig tests for package-link priority, config-file based packagefiles.xml discovery, and macro expansion. Register missing RemoveUnusedUnits files in the server package. --- .gitignore | 4 +- src/serverprotocol/PasLS.General.pas | 5 +- src/serverprotocol/PasLS.LazConfig.pas | 394 ++++++++++++++++++++++--- src/serverprotocol/PasLS.Settings.pas | 4 +- src/serverprotocol/lspserver.lpk | 8 + src/tests/Tests.LazConfig.pas | 286 ++++++++++++++++++ src/tests/testlsp.lpi | 4 + src/tests/testlsp.lpr | 2 +- 8 files changed, 664 insertions(+), 43 deletions(-) create mode 100644 src/tests/Tests.LazConfig.pas diff --git a/.gitignore b/.gitignore index b3c881a..93201c9 100644 --- a/.gitignore +++ b/.gitignore @@ -46,4 +46,6 @@ clients/pasls-vscode/out/* # 3rd-party editor projects *.code-workspace *.sublime-project -*.sublime-workspace \ No newline at end of file +*.sublime-workspace + +/src/tests/testlsp \ No newline at end of file diff --git a/src/serverprotocol/PasLS.General.pas b/src/serverprotocol/PasLS.General.pas index 305e276..80a5a1c 100644 --- a/src/serverprotocol/PasLS.General.pas +++ b/src/serverprotocol/PasLS.General.pas @@ -439,11 +439,11 @@ function TInitialize.Process(var Params : TLSPInitializeParams): TInitializeResu FPCTARGETCPU = FPC target cpu like i386, x86_64, arm } CodeToolsOptions.InitWithEnvironmentVariables; - GuessCodeToolConfig(Transport, CodeToolsOptions); + GuessCodeToolConfig(Transport, CodeToolsOptions, ServerSettings.config); if Assigned(Opt) then Proj := Opt.&program; if (Proj <> '') and FileExists(Proj) then - ConfigureSingleProject(Transport, Proj); + ConfigureSingleProject(Transport, Proj, CodeToolsOptions); // load the symbol manager if it's enabled if ServerSettings.documentSymbols or ServerSettings.workspaceSymbols then @@ -605,4 +605,3 @@ function TLSPInitializeParams.createInitializationOptions: TInitializationOption end; end. - diff --git a/src/serverprotocol/PasLS.LazConfig.pas b/src/serverprotocol/PasLS.LazConfig.pas index b7f95fa..efa2d94 100644 --- a/src/serverprotocol/PasLS.LazConfig.pas +++ b/src/serverprotocol/PasLS.LazConfig.pas @@ -57,6 +57,8 @@ TDependency = record Package: TPackage; end; + TPackageLinkPriority = (plGlobalLink, plDiscoveredConfig, plExplicitConfig); + TLazProjectConfig = class; TPackage = class @@ -120,6 +122,7 @@ TLazProjectConfig = class Private Class var PkgNameToPath: TFPStringHashTable; + PkgNameToPriority: TFPStringHashTable; // Map Path -> TPackage PkgCache: TFPObjectHashTable; _FakeAppName, @@ -133,6 +136,17 @@ TLazProjectConfig = class procedure LoadAllPackagesUnderPath(const Dir: string); function LoadPackageOrProject(const FileName: string): TPackage; function LookupGlobalPackage(const Name: String): String; + function ContainsUnresolvedMacro(const Path: string): Boolean; + function ExpandPathMacros(const Path: string; const BaseDir: string = ''; + const ProjOutDir: string = ''): string; + function NormalizeConfigDir(const ConfigPath: string): string; + function ReadPackageNameFromFile(const FileName: string): string; + function ReadNodeValue(Parent: TDomNode; const NodeName: domstring): string; + procedure RegisterPackageLink(const Name, FileName, BaseDir: string; + Priority: TPackageLinkPriority); + procedure PopulateGlobalLinks(const LazarusDirectory: string); + procedure PopulatePackageFiles(const ConfigDir: string; + Priority: TPackageLinkPriority); procedure PopulateGlobalPackages(const SearchPaths: array of string); Protected procedure DebugLog(const Msg: string); overload; @@ -144,13 +158,15 @@ TLazProjectConfig = class Class Constructor Init; Class Destructor Done; Constructor create(aTransport : TMessageTransport; aOptions: TCodeToolsOptions); - Procedure GuessCodeToolConfig; + Procedure GuessCodeToolConfig(const ConfigDir: string = ''); procedure ConfigurePaths(const Dir: string); procedure ConfigureSingleProject(const aProjectFile : string); end; -procedure GuessCodeToolConfig(aTransport : TMessageTransport; aOptions: TCodeToolsOptions); -procedure ConfigureSingleProject(aTransport : TMessageTransport; const aProjectFile : string); +procedure GuessCodeToolConfig(aTransport : TMessageTransport; aOptions: TCodeToolsOptions; + const ConfigDir: string = ''); +procedure ConfigureSingleProject(aTransport : TMessageTransport; const aProjectFile : string; + aOptions: TCodeToolsOptions = nil); implementation @@ -160,7 +176,8 @@ implementation // CodeTools needs to know the paths for the global packages, the FPC source // files, the path of the compiler and the target architecture. // Attempt to guess the correct settings from Lazarus config files. -procedure GuessCodeToolConfig(aTransport : TMessageTransport; aOptions: TCodeToolsOptions); +procedure GuessCodeToolConfig(aTransport : TMessageTransport; aOptions: TCodeToolsOptions; + const ConfigDir: string); var Cfg : TLazProjectConfig; @@ -168,19 +185,19 @@ procedure GuessCodeToolConfig(aTransport : TMessageTransport; aOptions: TCodeToo begin Cfg:=TLazProjectConfig.Create(aTransport,aOptions); try - Cfg.GuessCodeToolConfig; + Cfg.GuessCodeToolConfig(ConfigDir); finally Cfg.Free; end; end; procedure ConfigureSingleProject(aTransport: TMessageTransport; - const aProjectFile: string); + const aProjectFile: string; aOptions: TCodeToolsOptions); var Cfg : TLazProjectConfig; begin - Cfg:=TLazProjectConfig.Create(aTransport,Nil); + Cfg:=TLazProjectConfig.Create(aTransport,aOptions); try Cfg.ConfigureSingleProject(aProjectFile); finally @@ -287,7 +304,7 @@ function GetFakeVendorName: string; procedure TLazProjectConfig.DebugLog(const Msg: string); begin - if (Msg <> '') then + if (Msg <> '') and Assigned(FTransport) then FTransPort.SendDiagnostic(Msg); end; @@ -348,7 +365,9 @@ procedure TLazProjectConfig.PopulateGlobalPackages(const SearchPaths: array of s for FileName in Files do begin - Name := ExtractFileNameOnly(FileName); + Name := ReadPackageNameFromFile(FileName); + if Name = '' then + Name := ExtractFileNameOnly(FileName); PkgNameToPath[UpperCase(Name)] := FileName; end; DebugLog(' Found %d packages', [Files.Count]); @@ -381,7 +400,7 @@ function TPackage.GetAdditionalPaths(SearchPaths: TDomNode; const What: domstrin var Node: TDomNode; Segments: TStringArray; - S, Segment, AbsSegment: string; + S, Segment, ExpandedSegment, AbsSegment, ProjOutDir: string; begin Result := ''; @@ -393,10 +412,21 @@ function TPackage.GetAdditionalPaths(SearchPaths: TDomNode; const What: domstrin S := UTF8Encode(Node.NodeValue); Segments := S.Split([';'], TStringSplitOptions.ExcludeEmpty); + ProjOutDir := FConfig.ReadNodeValue(SearchPaths, 'UnitOutputDirectory'); + if ProjOutDir <> '' then + begin + ProjOutDir := FConfig.ExpandPathMacros(ProjOutDir, Dir); + if not FConfig.ContainsUnresolvedMacro(ProjOutDir) then + ProjOutDir := CreateAbsolutePath(ProjOutDir, Dir); + end; for Segment in Segments do begin - AbsSegment := CreateAbsolutePath(Segment, Dir); + ExpandedSegment := FConfig.ExpandPathMacros(Segment, Dir, ProjOutDir); + if FConfig.ContainsUnresolvedMacro(ExpandedSegment) then + AbsSegment := ExpandedSegment + else + AbsSegment := CreateAbsolutePath(ExpandedSegment, Dir); Result := Result + ';' + AbsSegment; end; end; @@ -487,8 +517,9 @@ procedure TPackage.LoadDeps(Root : TDomNode); Procedure TPackage.LoadFromFile(const aFileName : string); var - Doc: TXMLDocument; - Root: TDomNode; + Doc: TXMLDocument; + ConfigRoot, + Root: TDomNode; begin Valid := False; @@ -497,21 +528,30 @@ procedure TPackage.LoadDeps(Root : TDomNode); try try - ReadXMLFile(doc, afilename); + ReadXMLFile(Doc, afilename); - Root := Doc.DocumentElement; - if Root.NodeName <> 'CONFIG' then + ConfigRoot := Doc.DocumentElement; + if ConfigRoot.NodeName <> 'CONFIG' then Exit; if UpperCase(ExtractFileExt(aFileName)) = '.LPK' then - Root := Root.FindNode('Package') + begin + Root := ConfigRoot.FindNode('Package'); + if not Assigned(Root) then + Exit; + LoadPaths(Root); + end else - Root := Root.FindNode('ProjectOptions'); + begin + Root := ConfigRoot.FindNode('ProjectOptions'); + if not Assigned(Root) then + Exit; + LoadPaths(ConfigRoot); + end; if not Assigned(Root) then Exit; - LoadPaths(Root); LoadDeps(Root); Valid := True; @@ -537,17 +577,264 @@ function TLazProjectConfig.LookupGlobalPackage(const Name: String): String; Result := PkgNameToPath[UpperCase(Name)]; end; +function TLazProjectConfig.ContainsUnresolvedMacro(const Path: string): Boolean; +begin + Result := Pos('$', Path) > 0; +end; + +function TLazProjectConfig.ExpandPathMacros(const Path: string; const BaseDir: string; + const ProjOutDir: string): string; +var + SrcOS, SrcOS2, FPCVer, ProjectDir: string; + + procedure ReplaceMacro(const MacroName, Value: string); + begin + if Value = '' then + Exit; + Result := StringReplace(Result, '$(' + MacroName + ')', Value, [rfReplaceAll, rfIgnoreCase]); + Result := StringReplace(Result, '$(#' + MacroName + ')', Value, [rfReplaceAll, rfIgnoreCase]); + Result := StringReplace(Result, '$' + MacroName, Value, [rfReplaceAll, rfIgnoreCase]); + end; + +begin + Result := StringReplace(Path, '\', DirectorySeparator, [rfReplaceAll]); + ProjectDir := IncludeTrailingPathDelimiter(BaseDir); + if BaseDir <> '' then + begin + ReplaceMacro('ProjPath', ProjectDir); + ReplaceMacro('ProjDir', ProjectDir); + end; + ReplaceMacro('ProjOutDir', ProjOutDir); + + if not Assigned(Options) then + Exit; + + SrcOS := GetDefaultSrcOSForTargetOS(Options.TargetOS); + SrcOS2 := GetDefaultSrcOS2ForTargetOS(Options.TargetOS); + FPCVer := {$I %FPCVERSION%}; + + ReplaceMacro('LazarusDir', Options.LazarusSrcDir); + ReplaceMacro('LazarusSrcDir', Options.LazarusSrcDir); + ReplaceMacro('FPCSrcDir', Options.FPCSrcDir); + ReplaceMacro('TargetOS', Options.TargetOS); + ReplaceMacro('TargetCPU', Options.TargetProcessor); + ReplaceMacro('SrcOS', SrcOS); + ReplaceMacro('SrcOS2', SrcOS2); + ReplaceMacro('LCLWidgetType', Options.LCLWidgetType); + ReplaceMacro('FPCVer', FPCVer); + ReplaceMacro('FPCVersion', FPCVer); +end; + +function TLazProjectConfig.NormalizeConfigDir(const ConfigPath: string): string; +var + ExpandedPath: string; +begin + Result := ''; + if ConfigPath = '' then + Exit; + + ExpandedPath := ExpandFileName(ConfigPath); + if DirectoryExists(ExpandedPath) then + Result := ExpandedPath + else if FileExists(ExpandedPath) then + Result := ExtractFilePath(ExpandedPath); +end; + +function TLazProjectConfig.ReadNodeValue(Parent: TDomNode; + const NodeName: domstring): string; +var + Node: TDomNode; +begin + Result := ''; + if not Assigned(Parent) then + Exit; + + Node := Parent.FindNode(NodeName); + if Assigned(Node) then + Node := Node.Attributes.GetNamedItem('Value'); + if Assigned(Node) then + Result := UTF8Encode(Node.NodeValue); +end; + +function TLazProjectConfig.ReadPackageNameFromFile(const FileName: string): string; +var + Doc: TXMLDocument; + Root, PackageNode, NameNode: TDomNode; +begin + Result := ''; + Doc := nil; + try + try + ReadXMLFile(Doc, FileName); + Root := Doc.DocumentElement; + if not Assigned(Root) or (Root.NodeName <> 'CONFIG') then + Exit; + + PackageNode := Root.FindNode('Package'); + if not Assigned(PackageNode) then + Exit; + + NameNode := PackageNode.FindNode('Name'); + if Assigned(NameNode) then + NameNode := NameNode.Attributes.GetNamedItem('Value'); + if Assigned(NameNode) then + Result := UTF8Encode(NameNode.NodeValue); + except + on E: Exception do + DebugLog('Error %s reading package name from %s: %s', [E.ClassName, FileName, E.Message]); + end; + finally + FreeAndNil(Doc); + end; +end; + +procedure TLazProjectConfig.RegisterPackageLink(const Name, FileName, BaseDir: string; + Priority: TPackageLinkPriority); +var + PackageName, PackageFile, Key: string; + ExistingPriority: Integer; +begin + PackageFile := Trim(FileName); + if PackageFile = '' then + Exit; + + PackageFile := ExpandPathMacros(PackageFile, BaseDir); + if not ContainsUnresolvedMacro(PackageFile) then + PackageFile := CreateAbsolutePath(PackageFile, BaseDir); + + if not FileExists(PackageFile) then + Exit; + + PackageName := Trim(Name); + if PackageName = '' then + PackageName := ReadPackageNameFromFile(PackageFile); + if PackageName = '' then + PackageName := ExtractFileNameOnly(PackageFile); + + Key := UpperCase(PackageName); + ExistingPriority := StrToIntDef(PkgNameToPriority[Key], -1); + if ExistingPriority > Ord(Priority) then + Exit; + + PkgNameToPath[Key] := PackageFile; + PkgNameToPriority[Key] := IntToStr(Ord(Priority)); + DebugLog(' Package link: %s -> %s', [PackageName, PackageFile]); +end; + +procedure TLazProjectConfig.PopulatePackageFiles(const ConfigDir: string; + Priority: TPackageLinkPriority); +var + Doc: TXMLDocument; + Root, Links, Item, NameNode, FileNode: TDomNode; + Count: Integer; + FN, BaseDir, Name, FileName: string; + + procedure LoadLinks(const LinkNodeName: string); + var + i: Integer; + begin + Links := Root.FindNode(LinkNodeName); + if not Assigned(Links) then + Exit; + + for i := 0 to Links.ChildNodes.Count - 1 do + begin + Item := Links.ChildNodes.Item[i]; + Name := ''; + FileName := ''; + + NameNode := Item.FindNode('Name'); + if Assigned(NameNode) then + NameNode := NameNode.Attributes.GetNamedItem('Value'); + if Assigned(NameNode) then + Name := UTF8Encode(NameNode.NodeValue); + + FileNode := Item.FindNode('Filename'); + if Assigned(FileNode) then + FileNode := FileNode.Attributes.GetNamedItem('Value'); + if Assigned(FileNode) then + FileName := UTF8Encode(FileNode.NodeValue); + + if FileName <> '' then + begin + RegisterPackageLink(Name, FileName, BaseDir, Priority); + Inc(Count); + end; + end; + end; + +begin + if ConfigDir = '' then + Exit; + + FN := IncludeTrailingPathDelimiter(ConfigDir) + 'packagefiles.xml'; + if not FileExists(FN) then + Exit; + + DebugLog('Reading package links from %s', [FN]); + Doc := nil; + Count := 0; + BaseDir := IncludeTrailingPathDelimiter(ConfigDir); + try + try + ReadXMLFile(Doc, FN); + Root := Doc.DocumentElement; + if not Assigned(Root) or (Root.NodeName <> 'CONFIG') then + Exit; + + LoadLinks('UserPkgLinks'); + LoadLinks('GlobalPkgLinks'); + DebugLog(' Found %d package file links', [Count]); + except + on E: Exception do + DebugLog('Error %s reading package links from %s: %s', [E.ClassName, FN, E.Message]); + end; + finally + FreeAndNil(Doc); + end; +end; + +procedure TLazProjectConfig.PopulateGlobalLinks(const LazarusDirectory: string); +var + Files: TStringList; + LinkFile, PackageFile, LinkDir: string; +begin + if LazarusDirectory = '' then + Exit; + + LinkDir := IncludeTrailingPathDelimiter(LazarusDirectory) + 'packager' + + DirectorySeparator + 'globallinks'; + if not DirectoryExists(LinkDir) then + Exit; + + DebugLog('Reading global package links from %s/*.lpl', [LinkDir]); + Files := TStringList.Create; + try + FindAllFiles(Files, LinkDir, '*.lpl', False); + for LinkFile in Files do + begin + PackageFile := Trim(ReadFileToString(LinkFile)); + RegisterPackageLink('', PackageFile, ExtractFilePath(LinkFile), plGlobalLink); + end; + DebugLog(' Found %d global package links', [Files.Count]); + finally + Files.Free; + end; +end; + { TLazProjectConfig } class constructor TLazProjectConfig.Init; begin - PkgNameToPath := TFPStringHashTable.Create; - PkgCache := TFPObjectHashTable.Create; + PkgNameToPath := TFPStringHashTable.Create; + PkgNameToPriority := TFPStringHashTable.Create; + PkgCache := TFPObjectHashTable.Create; end; class destructor TLazProjectConfig.Done; begin FreeAndNil(PkgNameToPath); + FreeAndNil(PkgNameToPriority); FreeAndNil(PkgCache); end; @@ -613,8 +900,8 @@ procedure TPackage.ResolveDeps; // // Consider the following scenario: // -// A requires: -// - B (found) +// A requires: +// - B (found) // - C (NOT found) // B requires: // - C (found) @@ -718,11 +1005,11 @@ function TLazProjectConfig.IgnoreDirectory(const Dir: string): Boolean; DirName: string; begin Dirname := lowercase(ExtractFileName(Dir)); - Result := - (DirName = '.git') or + Result := + (DirName = '.git') or ((Length(DirName) >= 1) and (DirName[1] = '.')) or - (DirName = 'backup') or - (DirName = 'lib') or + (DirName = 'backup') or + (DirName = 'lib') or (Pos('.dsym', DirName) > 0) or (Pos('.app', DirName) > 0); end; @@ -732,7 +1019,7 @@ procedure TLazProjectConfig.LoadAllPackagesUnderPath(const Dir: string); var Packages, SubDirectories: TStringList; - i: integer; + i: integer; Pkg: TPackage; begin if IgnoreDirectory(Dir) then @@ -892,6 +1179,7 @@ procedure TLazProjectConfig.ConfigureSingleProject(const aProjectFile: string); if FileExists(FN) then begin Pkg := GetPackageOrProject(FN); + Pkg.ResolveDeps; Pkg.ResolvePaths; Pkg.Configure; end; @@ -902,20 +1190,21 @@ procedure TLazProjectConfig.ConfigureSingleProject(const aProjectFile: string); end; -procedure TLazProjectConfig.GuessCodeToolConfig; +procedure TLazProjectConfig.GuessCodeToolConfig(const ConfigDir: string); var ConfigDirs: TStringList; + PackageConfigDirs: TStringList; Doc: TXMLDocument; Root, - EnvironmentOptions, - FPCConfigs, + EnvironmentOptions, + FPCConfigs, Item1: TDomNode; - LazarusDirectory, - FPCSourceDirectory, - CompilerFilename, + LazarusDirectory, + FPCSourceDirectory, + CompilerFilename, OS, CPU: string; function LoadLazConfig(Path: string): Boolean; @@ -955,13 +1244,35 @@ procedure TLazProjectConfig.GuessCodeToolConfig; Var FN: string; Dir: string; + ExplicitConfigDir: string; + + procedure AddConfigDir(List: TStringList; const Path: string); + var + ExpandedPath: string; + begin + if Path = '' then + Exit; + ExpandedPath := ExpandFileName(Path); + if List.IndexOf(ExpandedPath) = -1 then + List.Add(ExpandedPath); + end; begin ConfigDirs := TStringList.Create; + PackageConfigDirs := TStringList.Create; try - ConfigDirs.Add(GetConfigDirForApp('lazarus', '', False)); - ConfigDirs.Add(GetUserDir + DirectorySeparator + '.lazarus'); - ConfigDirs.Add(GetConfigDirForApp('lazarus', '', True)); ; + ExplicitConfigDir := NormalizeConfigDir(ConfigDir); + + AddConfigDir(ConfigDirs, ExplicitConfigDir); + AddConfigDir(ConfigDirs, GetConfigDirForApp('lazarus', '', False)); + AddConfigDir(ConfigDirs, GetUserDir + DirectorySeparator + '.lazarus'); + AddConfigDir(ConfigDirs, GetConfigDirForApp('lazarus', '', True)); + + AddConfigDir(PackageConfigDirs, GetConfigDirForApp('lazarus', '', True)); + AddConfigDir(PackageConfigDirs, GetUserDir + DirectorySeparator + '.lazarus'); + AddConfigDir(PackageConfigDirs, GetConfigDirForApp('lazarus', '', False)); + AddConfigDir(PackageConfigDirs, ExplicitConfigDir); + for Dir in ConfigDirs do begin Doc := nil; @@ -1005,7 +1316,16 @@ procedure TLazProjectConfig.GuessCodeToolConfig; FreeAndNil(Doc); end; end; + PopulateGlobalLinks(Options.LazarusSrcDir); + for Dir in PackageConfigDirs do + begin + if Dir = ExplicitConfigDir then + PopulatePackageFiles(Dir, plExplicitConfig) + else + PopulatePackageFiles(Dir, plDiscoveredConfig); + end; finally + FreeAndNil(PackageConfigDirs); FreeAndNil(ConfigDirs); end; end; diff --git a/src/serverprotocol/PasLS.Settings.pas b/src/serverprotocol/PasLS.Settings.pas index 1e0c0df..6e8072c 100644 --- a/src/serverprotocol/PasLS.Settings.pas +++ b/src/serverprotocol/PasLS.Settings.pas @@ -249,7 +249,7 @@ procedure TServerSettings.ReplaceMacros(Macros: TMacroMap); var I: Integer; begin - { supported multiple formats: + { supported multiple formats: 1) $macro 2) $MACRO 3) $(macro) @@ -258,6 +258,8 @@ procedure TServerSettings.ReplaceMacros(Macros: TMacroMap); Result := S; for I := 0 to Macros.Count - 1 do begin + Result := StringReplace(Result, '$('+Macros.Keys[I]+')', Macros.Data[I], [rfReplaceAll, rfIgnoreCase]); + Result := StringReplace(Result, '$'+Macros.Keys[I], Macros.Data[I], [rfReplaceAll, rfIgnoreCase]); Result := StringReplace(Result, '$('+LowerCase(Macros.Keys[I])+')', Macros.Data[I], [rfReplaceAll]); Result := StringReplace(Result, '$('+UpperCase(Macros.Keys[I])+')', Macros.Data[I], [rfReplaceAll]); Result := StringReplace(Result, '$'+LowerCase(Macros.Keys[I]), Macros.Data[I], [rfReplaceAll]); diff --git a/src/serverprotocol/lspserver.lpk b/src/serverprotocol/lspserver.lpk index a7a4f18..b2cfbd9 100644 --- a/src/serverprotocol/lspserver.lpk +++ b/src/serverprotocol/lspserver.lpk @@ -138,6 +138,14 @@ + + + + + + + + diff --git a/src/tests/Tests.LazConfig.pas b/src/tests/Tests.LazConfig.pas new file mode 100644 index 0000000..e4da4c2 --- /dev/null +++ b/src/tests/Tests.LazConfig.pas @@ -0,0 +1,286 @@ +unit Tests.LazConfig; + +{$mode objfpc}{$H+} + +interface + +uses + Classes, SysUtils, fpcunit, testutils, testregistry, + CodeToolManager, CodeToolsConfig, FileUtil, fpjson, LSP.Messages; + +type + TNullTransport = class(TMessageTransport) + protected + procedure DoSendMessage(aMessage: TJSONData); override; + procedure DoSendDiagnostic(const aMessage: UTF8String); override; + end; + + { TTestLazConfig } + + TTestLazConfig = class(TTestCase) + private + FRoot: string; + FTransport: TNullTransport; + function MakeDir(const Parts: array of string): string; + function MakeFile(const Parts: array of string): string; + procedure WriteText(const FileName, Text: string); + procedure WritePackage(const FileName, PackageName, UnitPath: string; + const ExtraSearchPath: string = ''); + procedure WritePackageFiles(const ConfigDir, PackageName, PackageFile: string); + procedure WriteProject(const FileName, PackageName: string); + function NewOptions(const LazarusDir: string): TCodeToolsOptions; + function ConfigureProjectUnitPath(const ConfigPath, ProjectFile, + LazarusDir: string): string; + protected + procedure SetUp; override; + procedure TearDown; override; + published + procedure TestExplicitPackageLinkOverridesGlobalLink; + procedure TestConfigFilePathLoadsPackageFilesFromContainingDirectory; + procedure TestPathMacroExpansionKeepsUnknownMacrosRelative; + end; + +implementation + +uses + PasLS.LazConfig; + +procedure TNullTransport.DoSendMessage(aMessage: TJSONData); +begin +end; + +procedure TNullTransport.DoSendDiagnostic(const aMessage: UTF8String); +begin +end; + +function TTestLazConfig.MakeDir(const Parts: array of string): string; +var + Part: string; +begin + Result := FRoot; + for Part in Parts do + Result := IncludeTrailingPathDelimiter(Result) + Part; + Result := IncludeTrailingPathDelimiter(Result); + ForceDirectories(Result); +end; + +function TTestLazConfig.MakeFile(const Parts: array of string): string; +var + I: Integer; +begin + Result := FRoot; + for I := Low(Parts) to High(Parts) do + begin + if I = High(Parts) then + Result := IncludeTrailingPathDelimiter(Result) + Parts[I] + else + Result := IncludeTrailingPathDelimiter(Result) + Parts[I]; + end; +end; + +procedure TTestLazConfig.WriteText(const FileName, Text: string); +var + Lines: TStringList; +begin + ForceDirectories(ExtractFilePath(FileName)); + Lines := TStringList.Create; + try + Lines.Text := Text; + Lines.SaveToFile(FileName); + finally + Lines.Free; + end; +end; + +procedure TTestLazConfig.WritePackage(const FileName, PackageName, + UnitPath: string; const ExtraSearchPath: string); +var + SearchPath: string; +begin + ForceDirectories(UnitPath); + SearchPath := UnitPath; + if ExtraSearchPath <> '' then + SearchPath := SearchPath + ';' + ExtraSearchPath; + WriteText(FileName, + '' + LineEnding + + '' + LineEnding + + ' ' + LineEnding + + ' ' + LineEnding + + ' ' + LineEnding + + ' ' + LineEnding + + ' ' + LineEnding + + ' ' + LineEnding + + ' ' + LineEnding + + ' ' + LineEnding + + ' ' + LineEnding + + '' + LineEnding); +end; + +procedure TTestLazConfig.WritePackageFiles(const ConfigDir, PackageName, + PackageFile: string); +begin + ForceDirectories(ConfigDir); + WriteText(IncludeTrailingPathDelimiter(ConfigDir) + 'packagefiles.xml', + '' + LineEnding + + '' + LineEnding + + ' ' + LineEnding + + ' ' + LineEnding + + ' ' + LineEnding + + ' ' + LineEnding + + ' ' + LineEnding + + ' ' + LineEnding + + '' + LineEnding); +end; + +procedure TTestLazConfig.WriteProject(const FileName, PackageName: string); +begin + WriteText(FileName, + '' + LineEnding + + '' + LineEnding + + ' ' + LineEnding + + ' ' + LineEnding + + ' ' + LineEnding + + ' ' + LineEnding + + ' ' + LineEnding + + ' ' + LineEnding + + ' ' + LineEnding + + ' ' + LineEnding + + ' ' + LineEnding + + ' ' + LineEnding + + ' ' + LineEnding + + ' ' + LineEnding + + ' ' + LineEnding + + '' + LineEnding); +end; + +function TTestLazConfig.NewOptions(const LazarusDir: string): TCodeToolsOptions; +begin + Result := TCodeToolsOptions.Create; + Result.LazarusSrcDir := LazarusDir; + Result.FPCSrcDir := MakeDir(['fpcsrc']); + Result.TargetOS := 'linux'; + Result.TargetProcessor := 'x86_64'; + Result.LCLWidgetType := 'gtk2'; +end; + +function TTestLazConfig.ConfigureProjectUnitPath(const ConfigPath, + ProjectFile, LazarusDir: string): string; +var + Options: TCodeToolsOptions; +begin + Options := NewOptions(LazarusDir); + try + GuessCodeToolConfig(FTransport, Options, ConfigPath); + ConfigureSingleProject(FTransport, ProjectFile, Options); + Result := CodeToolBoss.GetUnitPathForDirectory(ExtractFilePath(ProjectFile), False); + finally + Options.Free; + end; +end; + +procedure TTestLazConfig.SetUp; +begin + FRoot := IncludeTrailingPathDelimiter(GetTempDir(False)) + + 'pasls-lazconfig-' + IntToStr(GetTickCount64); + ForceDirectories(FRoot); + FTransport := TNullTransport.Create; + CodeToolBoss.DefineTree.Clear; +end; + +procedure TTestLazConfig.TearDown; +begin + CodeToolBoss.DefineTree.Clear; + FreeAndNil(FTransport); + if FRoot <> '' then + DeleteDirectory(FRoot, False); +end; + +procedure TTestLazConfig.TestExplicitPackageLinkOverridesGlobalLink; +var + PackageName, LazarusDir, ConfigDir, ProjectFile, GlobalPkg, ExplicitPkg, + GlobalUnitDir, ExplicitUnitDir, UnitPath: string; +begin + PackageName := 'PkgOverride' + IntToStr(GetTickCount64); + LazarusDir := MakeDir(['lazarus']); + ConfigDir := MakeDir(['config']); + GlobalUnitDir := MakeDir(['global', 'units']); + ExplicitUnitDir := MakeDir(['explicit', 'units']); + GlobalPkg := MakeFile(['global', 'pkg.lpk']); + ExplicitPkg := MakeFile(['explicit', 'pkg.lpk']); + ProjectFile := MakeFile(['project', 'project.lpi']); + + WritePackage(GlobalPkg, PackageName, GlobalUnitDir); + WritePackage(ExplicitPkg, PackageName, ExplicitUnitDir); + WriteText(MakeFile(['lazarus', 'packager', 'globallinks', + LowerCase(PackageName) + '-1.0.lpl']), '$(LazarusDir)/../global/pkg.lpk'); + WritePackageFiles(ConfigDir, PackageName, ExplicitPkg); + WriteProject(ProjectFile, PackageName); + + UnitPath := ConfigureProjectUnitPath(ConfigDir, ProjectFile, LazarusDir); + + AssertTrue('explicit package unit path should win', + Pos(ExplicitUnitDir, UnitPath) > 0); + AssertFalse('global package unit path should not override explicit config', + Pos(GlobalUnitDir, UnitPath) > 0); +end; + +procedure TTestLazConfig.TestConfigFilePathLoadsPackageFilesFromContainingDirectory; +var + PackageName, LazarusDir, ConfigDir, ConfigFile, ProjectFile, PackageFile, + PackageUnitDir, UnitPath: string; +begin + PackageName := 'PkgConfigFile' + IntToStr(GetTickCount64); + LazarusDir := MakeDir(['lazarus']); + ConfigDir := MakeDir(['config']); + ConfigFile := IncludeTrailingPathDelimiter(ConfigDir) + 'environmentoptions.xml'; + PackageUnitDir := MakeDir(['package', 'units']); + PackageFile := MakeFile(['package', 'pkg.lpk']); + ProjectFile := MakeFile(['project', 'project.lpi']); + + WriteText(ConfigFile, '' + LineEnding); + WritePackage(PackageFile, PackageName, PackageUnitDir); + WritePackageFiles(ConfigDir, PackageName, PackageFile); + WriteProject(ProjectFile, PackageName); + + UnitPath := ConfigureProjectUnitPath(ConfigFile, ProjectFile, LazarusDir); + + AssertTrue('file-valued config should load sibling packagefiles.xml', + Pos(PackageUnitDir, UnitPath) > 0); +end; + +procedure TTestLazConfig.TestPathMacroExpansionKeepsUnknownMacrosRelative; +var + PackageName, LazarusDir, ConfigDir, ProjectFile, PackageFile, PackageDir, + PackageUnitDir, UnitPath, ExpectedProjOutDir, ExpectedLazarusPath: string; +begin + PackageName := 'PkgMacros' + IntToStr(GetTickCount64); + LazarusDir := MakeDir(['lazarus']); + ConfigDir := MakeDir(['config']); + PackageDir := MakeDir(['package']); + PackageUnitDir := MakeDir(['package', 'units']); + PackageFile := IncludeTrailingPathDelimiter(PackageDir) + 'pkg.lpk'; + ProjectFile := MakeFile(['project', 'project.lpi']); + ExpectedProjOutDir := IncludeTrailingPathDelimiter(PackageDir) + 'lib' + + DirectorySeparator + 'x86_64-linux'; + ExpectedLazarusPath := IncludeTrailingPathDelimiter(LazarusDir) + 'components' + + DirectorySeparator + 'x86_64-linux-gtk2'; + + WritePackage(PackageFile, PackageName, PackageUnitDir, + '$(ProjOutDir);$(LazarusDir)/components/$(TargetCPU)-$(TargetOS)-$(LCLWidgetType);$(UnknownMacro)/keep'); + WritePackageFiles(ConfigDir, PackageName, PackageFile); + WriteProject(ProjectFile, PackageName); + + UnitPath := ConfigureProjectUnitPath(ConfigDir, ProjectFile, LazarusDir); + + AssertTrue('ProjOutDir should expand using package UnitOutputDirectory', + Pos(ExpectedProjOutDir, UnitPath) > 0); + AssertTrue('Lazarus/target/widget macros should expand', + Pos(ExpectedLazarusPath, UnitPath) > 0); + AssertFalse('unknown macro should not be absolutized under package dir', + Pos(IncludeTrailingPathDelimiter(PackageDir) + '$(UnknownMacro)', UnitPath) > 0); +end; + +initialization + RegisterTest(TTestLazConfig); + +end. diff --git a/src/tests/testlsp.lpi b/src/tests/testlsp.lpi index 50ec1cc..b66531c 100644 --- a/src/tests/testlsp.lpi +++ b/src/tests/testlsp.lpi @@ -46,6 +46,10 @@ + + + + diff --git a/src/tests/testlsp.lpr b/src/tests/testlsp.lpr index aeabdc7..4043685 100644 --- a/src/tests/testlsp.lpr +++ b/src/tests/testlsp.lpr @@ -5,7 +5,7 @@ uses Classes, consoletestrunner, Tests.Basic, Tests.DocumentSymbol, Tests.SublimeProfile, Tests.SymbolPersistence, Tests.WorkspaceSymbol, - Tests.Diagnostic, Tests.ScanExamples, Tests.Streaming; + Tests.Diagnostic, Tests.ScanExamples, Tests.Streaming, Tests.LazConfig; type From 9a5814cdf268b3e87022af3a405f299ceaaaa636 Mon Sep 17 00:00:00 2001 From: Dmitry Moskowski Date: Fri, 26 Jun 2026 15:48:33 +0000 Subject: [PATCH 2/2] layered PasLS config and project inference - add system/user/project .pasls.cfg loading with project overrides - save selected main program into repo .pasls.cfg - infer compiler, target, FPC source dir, and main program where possible - improve cross-platform FPC source path inference, including Lazarus-adjacent layouts - configure workspace .lpk paths when no single main program is selected - resolve package dependencies before applying workspace package paths - add regression coverage for project config persistence and workspace package dependency paths --- README.md | 31 ++ src/serverprotocol/PasLS.AllCommands.pas | 4 +- .../PasLS.Command.SelectMainProgram.pas | 60 +++ src/serverprotocol/PasLS.General.pas | 344 +++++++++++++++++- src/serverprotocol/PasLS.LazConfig.pas | 27 +- src/serverprotocol/PasLS.Settings.pas | 272 +++++++++++++- src/serverprotocol/lspserver.lpk | 4 + src/serverprotocol/lspserver.pas | 4 +- src/standard/PasLS.LSConfig.pas | 7 +- src/standard/pasls.lpr | 1 + src/tests/Tests.Diagnostic.pas | 108 ++++++ src/tests/Tests.LazConfig.pas | 57 +++ 12 files changed, 899 insertions(+), 20 deletions(-) create mode 100644 src/serverprotocol/PasLS.Command.SelectMainProgram.pas diff --git a/README.md b/README.md index 4208f1d..5721ea5 100644 --- a/README.md +++ b/README.md @@ -121,6 +121,37 @@ configuration options. ### Configuration +#### pasls +The standard language server reads configuration in this order: + +1. built-in defaults +2. `/etc/pasls.cfg` +3. `~/.pasls.cfg` +4. `.pasls.cfg` in the workspace root +5. process environment variables +6. LSP initialization options + +Project selections are saved only to the workspace `.pasls.cfg`. If multiple +main programs are discovered, clients can call `pasls.selectMainProgram` with +the selected `.lpr` or `.dpr` path to persist it. + +```ini +[Project] +MainProgram=src/app.lpr + +[PasLS] +CodeToolsConfig=codetools.config +LazarusConfig=.lazarus + +[CodeTools] +Compiler=/usr/bin/fpc +FPCDir=/usr/share/fpcsrc +LazarusDir=/usr/share/lazarus +TargetOS=linux +TargetCPU=x86_64 +FPCOptions=-Fuunits -Fiinclude -dDEBUG +``` + #### paslssock The paslssock server can read an initialization file with 2 sections, `Server` and `CodeTools`. These can be used to set another port on which to diff --git a/src/serverprotocol/PasLS.AllCommands.pas b/src/serverprotocol/PasLS.AllCommands.pas index 54b420a..674f3a2 100644 --- a/src/serverprotocol/PasLS.AllCommands.pas +++ b/src/serverprotocol/PasLS.AllCommands.pas @@ -53,7 +53,8 @@ interface PasLS.Command.CompleteCode, PasLS.Command.InvertAssignment, PasLS.Command.RemoveEmptyMethods, - PasLS.Command.RemoveUnusedUnits; + PasLS.Command.RemoveUnusedUnits, + PasLS.Command.SelectMainProgram; procedure RegisterAllCommands; @@ -90,4 +91,3 @@ procedure RegisterAllCommands; end; end. - diff --git a/src/serverprotocol/PasLS.Command.SelectMainProgram.pas b/src/serverprotocol/PasLS.Command.SelectMainProgram.pas new file mode 100644 index 0000000..9e164a1 --- /dev/null +++ b/src/serverprotocol/PasLS.Command.SelectMainProgram.pas @@ -0,0 +1,60 @@ +// Pascal Language Server +// Copyright 2026 + +unit PasLS.Command.SelectMainProgram; + +{$mode objfpc}{$H+} + +interface + +uses + Classes, SysUtils, fpJSON, + LSP.BaseTypes, PasLS.Commands; + +type + + { TSelectMainProgramCommand } + + TSelectMainProgramCommand = class(TCustomCommand) + protected + function DoExecute(aArguments: TJSONArray): TLSPStreamable; override; + public + class function CommandName: string; override; + end; + +implementation + +uses + PasLS.Settings; + +function TSelectMainProgramCommand.DoExecute(aArguments: TJSONArray): TLSPStreamable; +var + MainProgram: String; +begin + Result := nil; + if (aArguments = nil) or (aArguments.Count = 0) then + Exit; + + MainProgram := ExpandFileName(aArguments.Strings[0]); + if not FileExists(MainProgram) then + begin + Transport.SendDiagnostic('Main program file "'+MainProgram+'" can''t be found.'); + Exit; + end; + + ServerSettings.&program := MainProgram; + if SaveProjectMainProgram(MainProgram) then + Transport.SendDiagnostic('Saved main program to '+ProjectConfigFile) + else + Transport.SendDiagnostic('Main program selected for this session, but project config context is unavailable.'); +end; + +class function TSelectMainProgramCommand.CommandName: string; +begin + Result := 'pasls.selectMainProgram'; +end; + +initialization + TSelectMainProgramCommand.Register; + +end. diff --git a/src/serverprotocol/PasLS.General.pas b/src/serverprotocol/PasLS.General.pas index 80a5a1c..596cad5 100644 --- a/src/serverprotocol/PasLS.General.pas +++ b/src/serverprotocol/PasLS.General.pas @@ -62,7 +62,10 @@ TInitialize = class(specialize TLSPRequest) implementation uses - SysUtils, RegExpr, IdentCompletionTool, DefineTemplates, + SysUtils, StrUtils, RegExpr, IdentCompletionTool, DefineTemplates, FileUtil, DOM, XMLRead, PasLS.CodeUtils; const @@ -128,6 +131,198 @@ procedure TInitialize.ApplyConfigSettings(CodeToolsOptions: TCodeToolsOptions); end; end; +procedure TInitialize.ApplyProjectCodeToolsConfig( + CodeToolsOptions: TCodeToolsOptions; ProjectConfig: TPasLSFileConfig); +begin + with CodeToolsOptions do + begin + if ProjectConfig.Compiler <> '' then + FPCPath := ProjectConfig.Compiler; + if ProjectConfig.FPCDir <> '' then + FPCSrcDir := ProjectConfig.FPCDir; + if ProjectConfig.LazarusDir <> '' then + LazarusSrcDir := ProjectConfig.LazarusDir; + if ProjectConfig.TargetOS <> '' then + TargetOS := ProjectConfig.TargetOS; + if ProjectConfig.TargetCPU <> '' then + TargetProcessor := ProjectConfig.TargetCPU; + end; +end; + +procedure TInitialize.ApplyGeneralInferences(CodeToolsOptions: TCodeToolsOptions); + + function PathDelimiter: Char; + begin + {$IFDEF WINDOWS} + Result := ';'; + {$ELSE} + Result := ':'; + {$ENDIF} + end; + + function FindExecutableInPath(const Names: array of String): String; + var + Paths: TStringList; + PathEntry, Name, Candidate: String; + begin + Result := ''; + Paths := TStringList.Create; + try + Paths.StrictDelimiter := True; + Paths.Delimiter := PathDelimiter; + Paths.DelimitedText := GetEnvironmentVariable('PATH'); + for PathEntry in Paths do + for Name in Names do + begin + Candidate := IncludeTrailingPathDelimiter(PathEntry) + Name; + {$IFDEF WINDOWS} + if ExtractFileExt(Candidate) = '' then + Candidate := Candidate + '.exe'; + {$ENDIF} + if FileExists(Candidate) then + Exit(ExpandFileName(Candidate)); + end; + finally + Paths.Free; + end; + end; + + procedure AddDirectoryCandidate(Candidates: TStrings; const Candidate: String); + var + Normalized: String; + begin + if Candidate = '' then + Exit; + Normalized := ExcludeTrailingPathDelimiter(Candidate); + if Candidates.IndexOf(Normalized) = -1 then + Candidates.Add(Normalized); + end; + + function ExistingDirectory(Candidates: TStrings): String; + var + Candidate: String; + begin + Result := ''; + for Candidate in Candidates do + if DirectoryExists(Candidate) then + Exit(ExpandFileName(Candidate)); + end; + + function ParentDir(const Path: String): String; + begin + Result := ExcludeTrailingPathDelimiter(ExtractFilePath(ExcludeTrailingPathDelimiter(Path))); + end; + + procedure AddFPCSourceCandidates(Candidates: TStrings; const Root: String); + var + Base: String; + begin + if Root = '' then + Exit; + Base := IncludeTrailingPathDelimiter(Root); + AddDirectoryCandidate(Candidates, Base + 'share' + DirectorySeparator + 'fpcsrc'); + AddDirectoryCandidate(Candidates, Base + 'share' + DirectorySeparator + 'fpcsrc' + DirectorySeparator + {$I %FPCVERSION%}); + AddDirectoryCandidate(Candidates, Base + 'source'); + AddDirectoryCandidate(Candidates, Base + 'source' + DirectorySeparator + {$I %FPCVERSION%}); + AddDirectoryCandidate(Candidates, Base + 'src'); + AddDirectoryCandidate(Candidates, Base + 'fpcsrc'); + end; + + procedure AddFPCSourceCandidatesFromLazarus(Candidates: TStrings; const LazarusDir: String); + var + ShareDir: String; + begin + if LazarusDir = '' then + Exit; + ShareDir := ParentDir(LazarusDir); + AddDirectoryCandidate(Candidates, IncludeTrailingPathDelimiter(ShareDir) + 'fpcsrc'); + AddDirectoryCandidate(Candidates, IncludeTrailingPathDelimiter(ShareDir) + 'fpcsrc' + DirectorySeparator + {$I %FPCVERSION%}); + AddFPCSourceCandidates(Candidates, ParentDir(ShareDir)); + end; + + procedure ApplyTargetFromOptions; + var + I: Integer; + Option: String; + begin + I := 0; + while I < ServerSettings.fpcOptions.Count do + begin + Option := ServerSettings.fpcOptions[I]; + if AnsiStartsStr('-T', Option) and (Length(Option) > 2) then + CodeToolsOptions.TargetOS := Copy(Option, 3, MaxInt) + else if (Option = '-T') and (I + 1 < ServerSettings.fpcOptions.Count) then + begin + Inc(I); + CodeToolsOptions.TargetOS := ServerSettings.fpcOptions[I]; + end + else if AnsiStartsStr('-P', Option) and (Length(Option) > 2) then + CodeToolsOptions.TargetProcessor := Copy(Option, 3, MaxInt) + else if (Option = '-P') and (I + 1 < ServerSettings.fpcOptions.Count) then + begin + Inc(I); + CodeToolsOptions.TargetProcessor := ServerSettings.fpcOptions[I]; + end; + Inc(I); + end; + end; + +var + CompilerDir, InstallRoot, InferredCompiler, InferredFPCSrc: String; + Candidates: TStringList; +begin + if (CodeToolsOptions.FPCPath = '') or not FileExists(CodeToolsOptions.FPCPath) then + begin + InferredCompiler := FindExecutableInPath(['fpc', 'ppcx64', 'ppc386', 'ppca64', 'ppcarm']); + if InferredCompiler <> '' then + begin + CodeToolsOptions.FPCPath := InferredCompiler; + DoLog(kStatusPrefix+'Inferred compiler: '+InferredCompiler); + end; + end; + + ApplyTargetFromOptions; + + if (CodeToolsOptions.FPCSrcDir = '') or not DirectoryExists(CodeToolsOptions.FPCSrcDir) then + begin + CompilerDir := ExtractFilePath(CodeToolsOptions.FPCPath); + InstallRoot := ParentDir(CompilerDir); + Candidates := TStringList.Create; + try + AddDirectoryCandidate(Candidates, GetEnvironmentVariable('FPCDIR')); + AddFPCSourceCandidatesFromLazarus(Candidates, CodeToolsOptions.LazarusSrcDir); + AddFPCSourceCandidates(Candidates, InstallRoot); + AddFPCSourceCandidates(Candidates, ParentDir(InstallRoot)); + + {$IFDEF WINDOWS} + AddDirectoryCandidate(Candidates, 'C:\FPC\' + {$I %FPCVERSION%} + '\source'); + AddDirectoryCandidate(Candidates, 'C:\FPC\source'); + AddDirectoryCandidate(Candidates, 'C:\FPC\Src'); + {$ELSE} + {$IFDEF DARWIN} + AddDirectoryCandidate(Candidates, '/opt/homebrew/share/fpcsrc'); + AddDirectoryCandidate(Candidates, '/opt/homebrew/share/fpcsrc/' + {$I %FPCVERSION%}); + AddDirectoryCandidate(Candidates, '/opt/local/share/fpcsrc'); + AddDirectoryCandidate(Candidates, '/opt/local/share/fpcsrc/' + {$I %FPCVERSION%}); + {$ENDIF} + AddDirectoryCandidate(Candidates, '/usr/share/fpcsrc'); + AddDirectoryCandidate(Candidates, '/usr/share/fpcsrc/' + {$I %FPCVERSION%}); + AddDirectoryCandidate(Candidates, '/usr/local/share/fpcsrc'); + AddDirectoryCandidate(Candidates, '/usr/local/share/fpcsrc/' + {$I %FPCVERSION%}); + {$ENDIF} + + InferredFPCSrc := ExistingDirectory(Candidates); + if InferredFPCSrc <> '' then + begin + CodeToolsOptions.FPCSrcDir := InferredFPCSrc; + DoLog(kStatusPrefix+'Inferred FPC source directory: '+InferredFPCSrc); + end; + finally + Candidates.Free; + end; + end; +end; + procedure TInitialize.SetPlatformDefaults(CodeToolsOptions: TCodeToolsOptions); begin @@ -161,7 +356,8 @@ function TInitialize.IsPasExt(const aExtension: String): Boolean; E : String; begin E := LowerCase(aExtension); - result := (E = '.pas') or (E = '.pp') or (E = '.inc'); + result := (E = '.pas') or (E = '.pp') or (E = '.p') or + (E = '.inc') or (E = '.lpr') or (E = '.dpr'); end; procedure TInitialize.DoLog(const Msg: String); @@ -245,6 +441,109 @@ procedure TInitialize.CollectWorkSpacePaths(WorkspaceFolders: TWorkspaceFolderIt FindPascalSourceDirectories(IncludeTrailingPathDelimiter(UriToPath(TWorkspaceFolder(Item).uri)), aPaths, ExcludeFolders); end; +procedure TInitialize.InferMainProgram(const RootPath: String); + + function AttrValue(Node: TDOMNode; const AttrName: String): String; + var + Attr: TDOMNode; + begin + Result := ''; + if not Assigned(Node) or not Assigned(Node.Attributes) then + Exit; + Attr := Node.Attributes.GetNamedItem(AttrName); + if Assigned(Attr) then + Result := UTF8Encode(Attr.NodeValue); + end; + + procedure AddCandidate(Candidates: TStrings; const Candidate: String); + var + FullPath: String; + begin + if Candidate = '' then + Exit; + FullPath := ExpandFileName(Candidate); + if FileExists(FullPath) and (Candidates.IndexOf(FullPath) = -1) then + Candidates.Add(FullPath); + end; + + procedure AddMainFromLPI(Candidates: TStrings; const LPIFile: String); + var + Doc: TXMLDocument; + UnitsNode, UnitNode, FileNode: TDOMNode; + I: Integer; + FileName, Ext: String; + begin + Doc := nil; + try + try + ReadXMLFile(Doc, LPIFile); + if not Assigned(Doc.DocumentElement) then + Exit; + UnitsNode := Doc.DocumentElement.FindNode('ProjectOptions'); + if Assigned(UnitsNode) then + UnitsNode := UnitsNode.FindNode('Units'); + if not Assigned(UnitsNode) then + Exit; + + for I := 0 to UnitsNode.ChildNodes.Count - 1 do + begin + UnitNode := UnitsNode.ChildNodes.Item[I]; + FileNode := UnitNode.FindNode('Filename'); + if not Assigned(FileNode) then + Continue; + FileName := AttrValue(FileNode, 'Value'); + Ext := LowerCase(ExtractFileExt(FileName)); + if (Ext = '.lpr') or (Ext = '.dpr') then + AddCandidate(Candidates, ExpandFileName(IncludeTrailingPathDelimiter(ExtractFilePath(LPIFile)) + FileName)); + end; + except + on E: Exception do + DoLog(kFailedPrefix+'Unable to inspect project file '+LPIFile+': '+E.Message); + end; + finally + FreeAndNil(Doc); + end; + end; + +var + Candidates, Files: TStringList; + FileName: String; +begin + if (ServerSettings.&program <> '') or (RootPath = '') or not DirectoryExists(RootPath) then + Exit; + + Candidates := TStringList.Create; + Files := TStringList.Create; + try + Candidates.Sorted := True; + Candidates.Duplicates := dupIgnore; + + FindAllFiles(Files, RootPath, '*.lpi', True); + for FileName in Files do + AddMainFromLPI(Candidates, FileName); + + Files.Clear; + FindAllFiles(Files, RootPath, '*.lpr;*.dpr', True); + for FileName in Files do + AddCandidate(Candidates, FileName); + + if Candidates.Count = 1 then + begin + ServerSettings.&program := Candidates[0]; + DoLog(kStatusPrefix+'Inferred main program file: '+ServerSettings.&program); + end + else if Candidates.Count > 1 then + begin + DoLog(kFailedPrefix+'Multiple main program files found. Select one with pasls.selectMainProgram to save it in .pasls.cfg:'); + for FileName in Candidates do + DoLog(kEmptyPrefix+FileName); + end; + finally + Files.Free; + Candidates.Free; + end; +end; + procedure TInitialize.ShowConfigStatus(Params: TInitializeParams; CodeToolsOptions: TCodeToolsOptions); var ExcludeList, Option: String; @@ -360,13 +659,14 @@ function TInitialize.Process(var Params : TLSPInitializeParams): TInitializeResu end; var - Proj, Option, aPath, ConfigPath: String; + Proj, Option, aPath, ConfigPath, RootDir: String; CodeToolsOptions: TCodeToolsOptions; PathSwitchRegex: TRegExpr; Macros: TMacroMap; WorkspacePaths: TStringList; RootPath, IncludePathTemplate, UnitPathTemplate: TDefineTemplate; Opt: TServerSettings; + ProjectConfig: TPasLSFileConfig; FPCOptions: TStringArray; begin if Params.initializationOptions is TServerSettings then @@ -379,10 +679,12 @@ function TInitialize.Process(var Params : TLSPInitializeParams): TInitializeResu PathSwitchRegex := nil; WorkspacePaths := nil; Macros := nil; + ProjectConfig := nil; FPCOptions := []; try Macros := TMacroMap.Create; + ProjectConfig := TPasLSFileConfig.Create; CodeToolsOptions := TCodeToolsOptions.Create; PathSwitchRegex := TRegExpr.Create('^(-(Fu|Fi)+)(.*)$'); @@ -398,6 +700,22 @@ function TInitialize.Process(var Params : TLSPInitializeParams): TInitializeResu ServerSettings.Assign(Params.initializationOptions); PasLS.Settings.ClientInfo.Assign(Params.ClientInfo); + RootDir := ''; + if Params.rootUri <> '' then + RootDir := URIToPath(Params.rootURI) + else if Params.workspaceFolders.Count > 0 then + RootDir := URIToPath(TWorkspaceFolder(Params.workspaceFolders.Items[0]).uri); + if RootDir <> '' then + RootDir := IncludeTrailingPathDelimiter(ExpandFileName(RootDir)); + + SetProjectConfigContext(RootDir, ProjectConfigFileName(RootDir)); + if FileExists(ProjectConfigFile) then + begin + ProjectConfig.LoadFromFile(ProjectConfigFile, RootDir); + ProjectConfig.ApplyToServerSettings(ServerSettings, True); + DoLog(kStatusPrefix+'Project config: '+ProjectConfigFile); + end; + // Detect hierarchical document symbol support if Assigned(Params.capabilities) and Assigned(Params.capabilities.textDocument) and @@ -408,13 +726,13 @@ function TInitialize.Process(var Params : TLSPInitializeParams): TInitializeResu // replace macros in server settings Macros.Add('tmpdir', GetTempDir(true)); - Macros.Add('root', URIToPath(Params.rootUri)); + Macros.Add('root', RootDir); ServerSettings.ReplaceMacros(Macros); // set the project directory based on root URI path - if Params.rootUri <> '' then - CodeToolsOptions.ProjectDir := URIToPath(Params.rootURI); + if RootDir <> '' then + CodeToolsOptions.ProjectDir := RootDir; // print the root URI so we know which workspace folder is default DoLog(kStatusPrefix+'RootURI: '+Params.rootUri); @@ -428,6 +746,7 @@ function TInitialize.Process(var Params : TLSPInitializeParams): TInitializeResu // set some built-in defaults based on platform SetPlatformDefaults(CodeToolsOptions); ApplyConfigSettings(CodeToolsOptions); + ApplyProjectCodeToolsConfig(CodeToolsOptions, ProjectConfig); { Override default settings with environment variables. These are the required values which must be set: @@ -438,12 +757,16 @@ function TInitialize.Process(var Params : TLSPInitializeParams): TInitializeResu FPCTARGET = FPC target OS like linux, win32, darwin FPCTARGETCPU = FPC target cpu like i386, x86_64, arm } CodeToolsOptions.InitWithEnvironmentVariables; + ApplyGeneralInferences(CodeToolsOptions); GuessCodeToolConfig(Transport, CodeToolsOptions, ServerSettings.config); - if Assigned(Opt) then - Proj := Opt.&program; + InferMainProgram(RootDir); + CheckProgramSetting; + Proj := ServerSettings.&program; if (Proj <> '') and FileExists(Proj) then - ConfigureSingleProject(Transport, Proj, CodeToolsOptions); + ConfigureSingleProject(Transport, Proj, CodeToolsOptions) + else if RootDir <> '' then + ConfigureProjectPaths(Transport, RootDir, CodeToolsOptions); // load the symbol manager if it's enabled if ServerSettings.documentSymbols or ServerSettings.workspaceSymbols then @@ -502,8 +825,6 @@ function TInitialize.Process(var Params : TLSPInitializeParams): TInitializeResu end; end; - CheckProgramSetting; - ShowConfigStatus(Params, CodeToolsOptions); with CodeToolBoss do @@ -532,6 +853,7 @@ function TInitialize.Process(var Params : TLSPInitializeParams): TInitializeResu WorkspacePaths.Free; PathSwitchRegex.Free; CodeToolsOptions.Free; + ProjectConfig.Free; Macros.Free; end; end; diff --git a/src/serverprotocol/PasLS.LazConfig.pas b/src/serverprotocol/PasLS.LazConfig.pas index efa2d94..7864d8b 100644 --- a/src/serverprotocol/PasLS.LazConfig.pas +++ b/src/serverprotocol/PasLS.LazConfig.pas @@ -167,6 +167,8 @@ procedure GuessCodeToolConfig(aTransport : TMessageTransport; aOptions: TCodeToo const ConfigDir: string = ''); procedure ConfigureSingleProject(aTransport : TMessageTransport; const aProjectFile : string; aOptions: TCodeToolsOptions = nil); +procedure ConfigureProjectPaths(aTransport : TMessageTransport; const aProjectDir : string; + aOptions: TCodeToolsOptions = nil); implementation @@ -205,6 +207,20 @@ procedure ConfigureSingleProject(aTransport: TMessageTransport; end; end; +procedure ConfigureProjectPaths(aTransport: TMessageTransport; const aProjectDir: string; + aOptions: TCodeToolsOptions); +var + Cfg : TLazProjectConfig; + +begin + Cfg:=TLazProjectConfig.Create(aTransport,aOptions); + try + Cfg.ConfigurePaths(aProjectDir); + finally + Cfg.Free; + end; +end; + { TPackage } @@ -1025,6 +1041,8 @@ procedure TLazProjectConfig.LoadAllPackagesUnderPath(const Dir: string); if IgnoreDirectory(Dir) then Exit; + Packages := nil; + SubDirectories := nil; try Packages := FindAllFiles( Dir, '*.lpi;*.lpk', False, faAnyFile and not faDirectory @@ -1045,7 +1063,7 @@ procedure TLazProjectConfig.LoadAllPackagesUnderPath(const Dir: string); finally if Assigned(Packages) then FreeAndNil(Packages); - if Assigned(Packages) then + if Assigned(SubDirectories) then FreeAndNil(SubDirectories); end; end; @@ -1061,6 +1079,8 @@ procedure TLazProjectConfig.GuessMissingDepsForAllPackages(const Dir: string); if IgnoreDirectory(Dir) then Exit; + Packages := nil; + SubDirectories := nil; try Packages := FindAllFiles( Dir, '*.lpi;*.lpk', False, faAnyFile and not faDirectory @@ -1080,7 +1100,7 @@ procedure TLazProjectConfig.GuessMissingDepsForAllPackages(const Dir: string); finally if Assigned(Packages) then FreeAndNil(Packages); - if Assigned(Packages) then + if Assigned(SubDirectories) then FreeAndNil(SubDirectories); end; end; @@ -1137,6 +1157,7 @@ procedure TLazProjectConfig.ConfigurePaths(const Dir: string); for i := 0 to Packages.Count - 1 do begin Pkg := GetPackageOrProject(Packages[i]); + Pkg.ResolveDeps; Pkg.ResolvePaths; end; @@ -1156,7 +1177,7 @@ procedure TLazProjectConfig.ConfigurePaths(const Dir: string); finally if Assigned(Packages) then FreeAndNil(Packages); - if Assigned(Packages) then + if Assigned(SubDirectories) then FreeAndNil(SubDirectories); end; end; diff --git a/src/serverprotocol/PasLS.Settings.pas b/src/serverprotocol/PasLS.Settings.pas index 6e8072c..0ad466a 100644 --- a/src/serverprotocol/PasLS.Settings.pas +++ b/src/serverprotocol/PasLS.Settings.pas @@ -30,6 +30,7 @@ interface const kSymbolName_Interface = 'interface'; kSymbolName_Implementation = 'implementation'; + kPasLSProjectConfigFile = '.pasls.cfg'; type TOverloadPolicy = ( __UNUSED__, @@ -175,6 +176,43 @@ TConfigEnvironmentSettings = class(TLSPStreamable) property fpcTargetCPU : string read ffpcTargetCPU write ffpcTargetCPU; end; + { TPasLSFileConfig } + + TPasLSFileConfig = class + private + fBaseDir: String; + fCodeToolsConfig: String; + fCompiler: String; + fFPCDir: String; + fFPCOptions: TStrings; + fLazarusConfig: String; + fLazarusDir: String; + fMainProgram: String; + fTargetCPU: String; + fTargetOS: String; + function ExpandConfigPath(const APath: String): String; + function ExpandFPCOption(const AOption: String): String; + function QuotePath(const APath: String): String; + procedure SetFPCOptions(AValue: TStrings); + public + constructor Create; + destructor Destroy; override; + procedure Clear; + procedure LoadFromFile(const AFileName: String; const ABaseDir: String = ''); + procedure ApplyToServerSettings(ASettings: TServerSettings; OnlyIfEmpty: Boolean); + procedure ApplyToEnvironment(ASettings: TConfigEnvironmentSettings; OnlyIfEmpty: Boolean); + property BaseDir: String read fBaseDir; + property MainProgram: String read fMainProgram; + property CodeToolsConfig: String read fCodeToolsConfig; + property LazarusConfig: String read fLazarusConfig; + property Compiler: String read fCompiler; + property FPCDir: String read fFPCDir; + property LazarusDir: String read fLazarusDir; + property TargetOS: String read fTargetOS; + property TargetCPU: String read fTargetCPU; + property FPCOptions: TStrings read fFPCOptions write SetFPCOptions; + end; + type TClients = class @@ -186,16 +224,52 @@ TClients = class Function ServerSettings: TServerSettings; Function ClientInfo: TClientInfo; Function EnvironmentSettings:TConfigEnvironmentSettings; +Function UserConfigFileName: String; +Function ProjectConfigFileName(const ProjectRoot: String): String; +Procedure SetProjectConfigContext(const ProjectRoot, ConfigFile: String); +Function ProjectRoot: String; +Function ProjectConfigFile: String; +Function SaveProjectMainProgram(const MainProgram: String): Boolean; implementation uses - SysUtils, lazUTF8; + SysUtils, IniFiles, StrUtils, lazUTF8; var _ServerSettings: TServerSettings; _ClientInfo: TClientInfo; _EnvironmentSettings:TConfigEnvironmentSettings; + _ProjectRoot: String; + _ProjectConfigFile: String; + +const + SProject = 'Project'; + SPasLS = 'PasLS'; + SCodeTools = 'CodeTools'; + KeyMainProgram = 'MainProgram'; + KeyCodeToolsConfig = 'CodeToolsConfig'; + KeyLazarusConfig = 'LazarusConfig'; + KeyCompiler = 'Compiler'; + KeyFPCDir = 'FPCDir'; + KeyLazarusDir = 'LazarusDir'; + KeyTargetOS = 'TargetOS'; + KeyTargetCPU = 'TargetCPU'; + KeyFPCOptions = 'FPCOptions'; + +function IsAbsoluteConfigPath(const APath: String): Boolean; +begin + Result := False; + if APath = '' then + Exit; + {$IFDEF WINDOWS} + Result := ((Length(APath) >= 3) and (APath[2] = ':') and + ((APath[3] = '\') or (APath[3] = '/'))) or + ((Length(APath) >= 2) and (APath[1] = '\') and (APath[2] = '\')); + {$ELSE} + Result := APath[1] = DirectorySeparator; + {$ENDIF} +end; { TExcludableSymbol helper functions } @@ -225,6 +299,61 @@ function ExcludableSymbolToStr(Symbol: TExcludableSymbol): string; Result:=_EnvironmentSettings; end; +function UserConfigFileName: String; +begin + Result := IncludeTrailingPathDelimiter(GetUserDir) + kPasLSProjectConfigFile; +end; + +function ProjectConfigFileName(const ProjectRoot: String): String; +begin + if ProjectRoot = '' then + Result := '' + else + Result := IncludeTrailingPathDelimiter(ProjectRoot) + kPasLSProjectConfigFile; +end; + +procedure SetProjectConfigContext(const ProjectRoot, ConfigFile: String); +begin + _ProjectRoot := ProjectRoot; + _ProjectConfigFile := ConfigFile; +end; + +function ProjectRoot: String; +begin + Result := _ProjectRoot; +end; + +function ProjectConfigFile: String; +begin + Result := _ProjectConfigFile; +end; + +function SaveProjectMainProgram(const MainProgram: String): Boolean; +var + Ini: TMemIniFile; + NormalizedMain, StoredMain, RootWithSep: String; +begin + Result := False; + if (_ProjectRoot = '') or (_ProjectConfigFile = '') or (MainProgram = '') then + Exit; + + NormalizedMain := ExpandFileName(MainProgram); + RootWithSep := IncludeTrailingPathDelimiter(ExpandFileName(_ProjectRoot)); + if AnsiStartsText(RootWithSep, NormalizedMain) then + StoredMain := ExtractRelativePath(RootWithSep, NormalizedMain) + else + StoredMain := NormalizedMain; + + Ini := TMemIniFile.Create(_ProjectConfigFile); + try + Ini.WriteString(SProject, KeyMainProgram, StoredMain); + Ini.UpdateFile; + Result := True; + finally + Ini.Free; + end; +end; + Function ServerSettings: TServerSettings; begin @@ -475,6 +604,147 @@ procedure TConfigEnvironmentSettings.Assign(aSource : TPersistent); inherited Assign(aSource); end; +{ TPasLSFileConfig } + +constructor TPasLSFileConfig.Create; +begin + inherited Create; + fFPCOptions := TStringList.Create; +end; + +destructor TPasLSFileConfig.Destroy; +begin + FreeAndNil(fFPCOptions); + inherited Destroy; +end; + +procedure TPasLSFileConfig.Clear; +begin + fBaseDir := ''; + fMainProgram := ''; + fCodeToolsConfig := ''; + fLazarusConfig := ''; + fCompiler := ''; + fFPCDir := ''; + fLazarusDir := ''; + fTargetOS := ''; + fTargetCPU := ''; + fFPCOptions.Clear; +end; + +function TPasLSFileConfig.QuotePath(const APath: String): String; +begin + if Pos(' ', APath) > 0 then + Result := '"' + APath + '"' + else + Result := APath; +end; + +function TPasLSFileConfig.ExpandConfigPath(const APath: String): String; +begin + Result := Trim(APath); + if Result = '' then + Exit; + if (fBaseDir <> '') and not IsAbsoluteConfigPath(Result) then + Result := ExpandFileName(IncludeTrailingPathDelimiter(fBaseDir) + Result) + else + Result := ExpandFileName(Result); +end; + +function TPasLSFileConfig.ExpandFPCOption(const AOption: String): String; +var + Prefix, PathPart: String; +begin + Result := Trim(AOption); + if (Result = '') or (fBaseDir = '') then + Exit; + + Prefix := ''; + PathPart := ''; + if AnsiStartsStr('-Fu', Result) or AnsiStartsStr('-Fi', Result) then + begin + Prefix := Copy(Result, 1, 3); + PathPart := Copy(Result, 4, MaxInt); + end + else if AnsiStartsStr('-I', Result) then + begin + Prefix := Copy(Result, 1, 2); + PathPart := Copy(Result, 3, MaxInt); + end; + + if (Prefix <> '') and (PathPart <> '') and not IsAbsoluteConfigPath(PathPart) then + Result := Prefix + QuotePath(ExpandFileName(IncludeTrailingPathDelimiter(fBaseDir) + PathPart)); +end; + +procedure TPasLSFileConfig.SetFPCOptions(AValue: TStrings); +begin + if fFPCOptions = AValue then + Exit; + fFPCOptions.Assign(AValue); +end; + +procedure TPasLSFileConfig.LoadFromFile(const AFileName: String; + const ABaseDir: String); +var + Ini: TMemIniFile; + RawOptions, Option: String; + ParsedOptions: TStringList; +begin + Clear; + fBaseDir := ABaseDir; + Ini := TMemIniFile.Create(AFileName); + ParsedOptions := TStringList.Create; + try + fMainProgram := ExpandConfigPath(Ini.ReadString(SProject, KeyMainProgram, '')); + fCodeToolsConfig := ExpandConfigPath(Ini.ReadString(SPasLS, KeyCodeToolsConfig, '')); + fLazarusConfig := ExpandConfigPath(Ini.ReadString(SPasLS, KeyLazarusConfig, '')); + fCompiler := ExpandConfigPath(Ini.ReadString(SCodeTools, KeyCompiler, '')); + fFPCDir := ExpandConfigPath(Ini.ReadString(SCodeTools, KeyFPCDir, '')); + fLazarusDir := ExpandConfigPath(Ini.ReadString(SCodeTools, KeyLazarusDir, '')); + fTargetOS := Ini.ReadString(SCodeTools, KeyTargetOS, ''); + fTargetCPU := Ini.ReadString(SCodeTools, KeyTargetCPU, ''); + + RawOptions := Ini.ReadString(SCodeTools, KeyFPCOptions, ''); + if RawOptions <> '' then + begin + ExtractStrings([' '], ['"'], PChar(RawOptions), ParsedOptions); + for Option in ParsedOptions do + fFPCOptions.Add(ExpandFPCOption(Option)); + end; + finally + ParsedOptions.Free; + Ini.Free; + end; +end; + +procedure TPasLSFileConfig.ApplyToServerSettings(ASettings: TServerSettings; + OnlyIfEmpty: Boolean); +begin + if (fMainProgram <> '') and ((not OnlyIfEmpty) or (ASettings.&program = '')) then + ASettings.&program := fMainProgram; + if (fCodeToolsConfig <> '') and ((not OnlyIfEmpty) or (ASettings.codeToolsConfig = '')) then + ASettings.codeToolsConfig := fCodeToolsConfig; + if (fLazarusConfig <> '') and ((not OnlyIfEmpty) or (ASettings.config = '')) then + ASettings.config := fLazarusConfig; + if (fFPCOptions.Count > 0) and ((not OnlyIfEmpty) or (ASettings.fpcOptions.Count = 0)) then + ASettings.fpcOptions := fFPCOptions; +end; + +procedure TPasLSFileConfig.ApplyToEnvironment(ASettings: TConfigEnvironmentSettings; + OnlyIfEmpty: Boolean); +begin + if (fCompiler <> '') and ((not OnlyIfEmpty) or (ASettings.pp = '')) then + ASettings.pp := fCompiler; + if (fFPCDir <> '') and ((not OnlyIfEmpty) or (ASettings.fpcDir = '')) then + ASettings.fpcDir := fFPCDir; + if (fLazarusDir <> '') and ((not OnlyIfEmpty) or (ASettings.lazarusDir = '')) then + ASettings.lazarusDir := fLazarusDir; + if (fTargetOS <> '') and ((not OnlyIfEmpty) or (ASettings.fpcTarget = '')) then + ASettings.fpcTarget := fTargetOS; + if (fTargetCPU <> '') and ((not OnlyIfEmpty) or (ASettings.fpcTargetCPU = '')) then + ASettings.fpcTargetCPU := fTargetCPU; +end; + finalization _ServerSettings.Free; _ClientInfo.Free; diff --git a/src/serverprotocol/lspserver.lpk b/src/serverprotocol/lspserver.lpk index b2cfbd9..32d9619 100644 --- a/src/serverprotocol/lspserver.lpk +++ b/src/serverprotocol/lspserver.lpk @@ -142,6 +142,10 @@ + + + + diff --git a/src/serverprotocol/lspserver.pas b/src/serverprotocol/lspserver.pas index 98ef08b..2b51f46 100644 --- a/src/serverprotocol/lspserver.pas +++ b/src/serverprotocol/lspserver.pas @@ -18,8 +18,8 @@ interface PasLS.DocumentSymbol, PasLS.Commands, PasLS.Formatter, PasLS.ExecuteCommand, PasLS.CodeUtils, PasLS.InvertAssign, PasLS.LazConfig, PasLS.Parser, PasLS.Symbols, PasLS.CheckInactiveRegions, PasLS.InactiveRegions, - PasLS.Command.RemoveUnusedUnits, PasLS.RemoveUnusedUnits, - PasLS.Rename, LazarusPackageIntf; + PasLS.Command.RemoveUnusedUnits, PasLS.Command.SelectMainProgram, + PasLS.RemoveUnusedUnits, PasLS.Rename, LazarusPackageIntf; implementation diff --git a/src/standard/PasLS.LSConfig.pas b/src/standard/PasLS.LSConfig.pas index e02d1b7..ef1aa90 100644 --- a/src/standard/PasLS.LSConfig.pas +++ b/src/standard/PasLS.LSConfig.pas @@ -49,6 +49,7 @@ interface Constructor Create; virtual; Procedure Reset; virtual; class Function DefaultConfigFile : String; + class Function UserConfigFile : String; Procedure LoadFromFile(const aFileName : String); Procedure SaveToFile(const aFileName : String); Procedure LoadFromIni(aIni : TCustomIniFile); virtual; @@ -102,6 +103,11 @@ class function TLSPServerConfig.DefaultConfigFile: String; {$ENDIF} end; +class function TLSPServerConfig.UserConfigFile: String; +begin + Result:=IncludeTrailingPathDelimiter(GetUserDir)+'.pasls.cfg'; +end; + procedure TLSPServerConfig.LoadFromFile(const aFileName: String); Var @@ -158,4 +164,3 @@ procedure TLSPServerConfig.SaveToIni(aIni: TCustomIniFile); end. - diff --git a/src/standard/pasls.lpr b/src/standard/pasls.lpr index ee373a1..7d98062 100644 --- a/src/standard/pasls.lpr +++ b/src/standard/pasls.lpr @@ -322,6 +322,7 @@ procedure TLSPLogContext.DoTransportLog(sender: TObject; const Msg: UTF8String); try RegisterAllCommands; aCfg.LoadFromFile(aCfg.DefaultConfigFile); + aCfg.LoadFromFile(aCfg.UserConfigFile); if aCfg.LogFile<>'' then TLSPContext.LogFile := aCfg.LogFile; ConfigEnvironment(aCfg); diff --git a/src/tests/Tests.Diagnostic.pas b/src/tests/Tests.Diagnostic.pas index 75492cd..41c47dc 100644 --- a/src/tests/Tests.Diagnostic.pas +++ b/src/tests/Tests.Diagnostic.pas @@ -25,6 +25,8 @@ interface TDiagnosticTests = class(TTestCase) private procedure Log(const Msg: String); + function MakeTempDir(const Prefix: String): String; + procedure WriteText(const FileName, Text: String); protected procedure SetUp; override; procedure TearDown; override; @@ -55,6 +57,12 @@ TDiagnosticTests = class(TTestCase) // Test 9: Full initialization simulation procedure Test09_SimulateInitialization; + + // Test 10: Project .pasls.cfg loading and relative path handling + procedure Test10_ProjectConfigLoadsRelativePaths; + + // Test 11: Project main program persistence writes only project config + procedure Test11_SaveProjectMainProgram; end; implementation @@ -69,6 +77,27 @@ procedure TDiagnosticTests.Log(const Msg: String); WriteLn('[DIAG] ' + Msg); end; +function TDiagnosticTests.MakeTempDir(const Prefix: String): String; +begin + Result := IncludeTrailingPathDelimiter(GetTempDir(False)) + Prefix + '-' + + IntToStr(Random(1000000)) + DirectorySeparator; + ForceDirectories(Result); +end; + +procedure TDiagnosticTests.WriteText(const FileName, Text: String); +var + S: TStringList; +begin + ForceDirectories(ExtractFilePath(FileName)); + S := TStringList.Create; + try + S.Text := Text; + S.SaveToFile(FileName); + finally + S.Free; + end; +end; + procedure TDiagnosticTests.SetUp; begin Log('=== SetUp ==='); @@ -395,6 +424,85 @@ procedure TDiagnosticTests.Test09_SimulateInitialization; end; end; +procedure TDiagnosticTests.Test10_ProjectConfigLoadsRelativePaths; +var + Root, ConfigFile: String; + Config: TPasLSFileConfig; + Settings: TServerSettings; + Env: TConfigEnvironmentSettings; +begin + Root := MakeTempDir('pasls-config'); + ConfigFile := IncludeTrailingPathDelimiter(Root) + kPasLSProjectConfigFile; + WriteText(ConfigFile, + '[Project]' + LineEnding + + 'MainProgram=src/app.lpr' + LineEnding + + LineEnding + + '[PasLS]' + LineEnding + + 'CodeToolsConfig=codetools.config' + LineEnding + + 'LazarusConfig=.lazarus' + LineEnding + + LineEnding + + '[CodeTools]' + LineEnding + + 'Compiler=bin/fpc' + LineEnding + + 'FPCDir=fpcsrc' + LineEnding + + 'LazarusDir=lazarus' + LineEnding + + 'TargetOS=linux' + LineEnding + + 'TargetCPU=x86_64' + LineEnding + + 'FPCOptions=-Fuunits -Fiinclude -dDEBUG' + LineEnding); + + Config := TPasLSFileConfig.Create; + Settings := TServerSettings.Create; + Env := TConfigEnvironmentSettings.Create; + try + Config.LoadFromFile(ConfigFile, Root); + Config.ApplyToServerSettings(Settings, True); + Config.ApplyToEnvironment(Env, False); + + AssertEquals('program path', ExpandFileName(Root + 'src/app.lpr'), Settings.&program); + AssertEquals('codetools config', ExpandFileName(Root + 'codetools.config'), Settings.codeToolsConfig); + AssertEquals('lazarus config', ExpandFileName(Root + '.lazarus'), Settings.config); + AssertEquals('fpc options count', 3, Settings.fpcOptions.Count); + AssertEquals('unit path option', '-Fu' + ExpandFileName(Root + 'units'), Settings.fpcOptions[0]); + AssertEquals('include path option', '-Fi' + ExpandFileName(Root + 'include'), Settings.fpcOptions[1]); + AssertEquals('define option', '-dDEBUG', Settings.fpcOptions[2]); + + AssertEquals('compiler', ExpandFileName(Root + 'bin/fpc'), Env.pp); + AssertEquals('fpc dir', ExpandFileName(Root + 'fpcsrc'), Env.fpcDir); + AssertEquals('lazarus dir', ExpandFileName(Root + 'lazarus'), Env.lazarusDir); + AssertEquals('target os', 'linux', Env.fpcTarget); + AssertEquals('target cpu', 'x86_64', Env.fpcTargetCPU); + finally + Env.Free; + Settings.Free; + Config.Free; + end; +end; + +procedure TDiagnosticTests.Test11_SaveProjectMainProgram; +var + Root, ConfigFile, MainFile: String; + Config: TPasLSFileConfig; +begin + Root := MakeTempDir('pasls-save'); + ConfigFile := IncludeTrailingPathDelimiter(Root) + kPasLSProjectConfigFile; + MainFile := IncludeTrailingPathDelimiter(Root) + 'src' + DirectorySeparator + 'app.lpr'; + WriteText(MainFile, 'program app; begin end.' + LineEnding); + if FileExists(ConfigFile) then + DeleteFile(ConfigFile); + + SetProjectConfigContext(Root, ConfigFile); + AssertFalse('config file should not exist before save', FileExists(ConfigFile)); + AssertTrue('save should create project config', SaveProjectMainProgram(MainFile)); + AssertTrue('config file should exist after save', FileExists(ConfigFile)); + + Config := TPasLSFileConfig.Create; + try + Config.LoadFromFile(ConfigFile, Root); + AssertEquals('saved main program', ExpandFileName(MainFile), Config.MainProgram); + finally + Config.Free; + end; +end; + initialization RegisterTest(TDiagnosticTests); diff --git a/src/tests/Tests.LazConfig.pas b/src/tests/Tests.LazConfig.pas index e4da4c2..3eb8162 100644 --- a/src/tests/Tests.LazConfig.pas +++ b/src/tests/Tests.LazConfig.pas @@ -26,6 +26,8 @@ TTestLazConfig = class(TTestCase) procedure WriteText(const FileName, Text: string); procedure WritePackage(const FileName, PackageName, UnitPath: string; const ExtraSearchPath: string = ''); + procedure WritePackageWithDependency(const FileName, PackageName, UnitPath, + DepPackageName, DepPackageFile: string); procedure WritePackageFiles(const ConfigDir, PackageName, PackageFile: string); procedure WriteProject(const FileName, PackageName: string); function NewOptions(const LazarusDir: string): TCodeToolsOptions; @@ -38,6 +40,7 @@ TTestLazConfig = class(TTestCase) procedure TestExplicitPackageLinkOverridesGlobalLink; procedure TestConfigFilePathLoadsPackageFilesFromContainingDirectory; procedure TestPathMacroExpansionKeepsUnknownMacrosRelative; + procedure TestWorkspacePackagePathsResolveDependencies; end; implementation @@ -116,6 +119,30 @@ procedure TTestLazConfig.WritePackage(const FileName, PackageName, '' + LineEnding); end; +procedure TTestLazConfig.WritePackageWithDependency(const FileName, PackageName, + UnitPath, DepPackageName, DepPackageFile: string); +begin + ForceDirectories(UnitPath); + WriteText(FileName, + '' + LineEnding + + '' + LineEnding + + ' ' + LineEnding + + ' ' + LineEnding + + ' ' + LineEnding + + ' ' + LineEnding + + ' ' + LineEnding + + ' ' + LineEnding + + ' ' + LineEnding + + ' ' + LineEnding + + ' ' + LineEnding + + ' ' + LineEnding + + ' ' + LineEnding + + ' ' + LineEnding + + ' ' + LineEnding + + ' ' + LineEnding + + '' + LineEnding); +end; + procedure TTestLazConfig.WritePackageFiles(const ConfigDir, PackageName, PackageFile: string); begin @@ -280,6 +307,36 @@ procedure TTestLazConfig.TestPathMacroExpansionKeepsUnknownMacrosRelative; Pos(IncludeTrailingPathDelimiter(PackageDir) + '$(UnknownMacro)', UnitPath) > 0); end; +procedure TTestLazConfig.TestWorkspacePackagePathsResolveDependencies; +var + LazarusDir, WorkspaceDir, AppPackageFile, DepPackageFile, AppUnitDir, + DepUnitDir, UnitPath: string; + Options: TCodeToolsOptions; +begin + LazarusDir := MakeDir(['lazarus']); + WorkspaceDir := MakeDir(['workspace']); + AppUnitDir := MakeDir(['workspace', 'app']); + DepUnitDir := MakeDir(['workspace', 'dep']); + AppPackageFile := IncludeTrailingPathDelimiter(WorkspaceDir) + 'app.lpk'; + DepPackageFile := IncludeTrailingPathDelimiter(WorkspaceDir) + 'dep.lpk'; + + WritePackage(DepPackageFile, 'DepPkg', DepUnitDir); + WritePackageWithDependency(AppPackageFile, 'AppPkg', AppUnitDir, 'DepPkg', + DepPackageFile); + + Options := NewOptions(LazarusDir); + try + GuessCodeToolConfig(FTransport, Options); + ConfigureProjectPaths(FTransport, WorkspaceDir, Options); + UnitPath := CodeToolBoss.GetUnitPathForDirectory(AppUnitDir, False); + finally + Options.Free; + end; + + AssertTrue('workspace package config should include dependency unit path', + Pos(DepUnitDir, UnitPath) > 0); +end; + initialization RegisterTest(TTestLazConfig);