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/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 305e276..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); - if Assigned(Opt) then - Proj := Opt.&program; + GuessCodeToolConfig(Transport, CodeToolsOptions, ServerSettings.config); + InferMainProgram(RootDir); + CheckProgramSetting; + Proj := ServerSettings.&program; if (Proj <> '') and FileExists(Proj) then - ConfigureSingleProject(Transport, Proj); + 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; @@ -605,4 +927,3 @@ function TLSPInitializeParams.createInitializationOptions: TInitializationOption end; end. - diff --git a/src/serverprotocol/PasLS.LazConfig.pas b/src/serverprotocol/PasLS.LazConfig.pas index b7f95fa..7864d8b 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,17 @@ 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); +procedure ConfigureProjectPaths(aTransport : TMessageTransport; const aProjectDir : string; + aOptions: TCodeToolsOptions = nil); implementation @@ -160,7 +178,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 +187,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 @@ -188,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 } @@ -287,7 +320,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 +381,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 +416,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 +428,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 +533,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 +544,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 +593,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 +916,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 +1021,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,12 +1035,14 @@ procedure TLazProjectConfig.LoadAllPackagesUnderPath(const Dir: string); var Packages, SubDirectories: TStringList; - i: integer; + i: integer; Pkg: TPackage; begin if IgnoreDirectory(Dir) then Exit; + Packages := nil; + SubDirectories := nil; try Packages := FindAllFiles( Dir, '*.lpi;*.lpk', False, faAnyFile and not faDirectory @@ -758,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; @@ -774,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 @@ -793,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; @@ -850,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; @@ -869,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; @@ -892,6 +1200,7 @@ procedure TLazProjectConfig.ConfigureSingleProject(const aProjectFile: string); if FileExists(FN) then begin Pkg := GetPackageOrProject(FN); + Pkg.ResolveDeps; Pkg.ResolvePaths; Pkg.Configure; end; @@ -902,20 +1211,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 +1265,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 +1337,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..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 @@ -249,7 +378,7 @@ procedure TServerSettings.ReplaceMacros(Macros: TMacroMap); var I: Integer; begin - { supported multiple formats: + { supported multiple formats: 1) $macro 2) $MACRO 3) $(macro) @@ -258,6 +387,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]); @@ -473,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 a7a4f18..32d9619 100644 --- a/src/serverprotocol/lspserver.lpk +++ b/src/serverprotocol/lspserver.lpk @@ -138,6 +138,18 @@ + + + + + + + + + + + + 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 new file mode 100644 index 0000000..3eb8162 --- /dev/null +++ b/src/tests/Tests.LazConfig.pas @@ -0,0 +1,343 @@ +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 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; + function ConfigureProjectUnitPath(const ConfigPath, ProjectFile, + LazarusDir: string): string; + protected + procedure SetUp; override; + procedure TearDown; override; + published + procedure TestExplicitPackageLinkOverridesGlobalLink; + procedure TestConfigFilePathLoadsPackageFilesFromContainingDirectory; + procedure TestPathMacroExpansionKeepsUnknownMacrosRelative; + procedure TestWorkspacePackagePathsResolveDependencies; + 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.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 + 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; + +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); + +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