paweld/lazarus
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/lazarus/lazarus.git synced 2025-09-20 11:59:21 +02:00
Code Issues Packages Projects Releases Wiki Activity

codetools: searching fpc source namespaced includes, issue #40670

Browse Source
This commit is contained in:
mattias 2023-12-30 15:29:44 +01:00
parent 5b454293c2
commit d2954c9818
5 changed files with 131 additions and 16 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

19
components/codetools/codetoolmanager.pas
View File

@ -383,6 +383,8 @@ type
function GetPCVersionForDirectory(const Directory: string; out Kind: TPascalCompiler): integer;
function GetNamespacesForDirectory(const Directory: string;
UseCache: boolean = true): string;// value of macro #Namespaces
function GetNamespacedIncludesForDirectory(const Directory: string;
UseCache: boolean = true): string;
// simple global defines for tests and simple projects
function GetGlobalDefines(CreateIfNotExists: boolean = true): TDefineTemplate;
@ -1783,6 +1785,22 @@ begin
end;
end;
function TCodeToolManager.GetNamespacedIncludesForDirectory(
const Directory: string; UseCache: boolean): string;
var
Evaluator: TExpressionEvaluator;
begin
if UseCache then begin
Result:=DirectoryCachePool.GetString(Directory,ctdcsNamespaces,true)
end else begin
Result:='';
Evaluator:=DefineTree.GetDefinesForDirectory(Directory,true);
if Evaluator=nil then exit;
if Evaluator.IsDefined(StdDefTemplCodetoolsFPCSrc) then
Result:='1';
end;
end;
function TCodeToolManager.GetGlobalDefines(CreateIfNotExists: boolean
): TDefineTemplate;
begin
@ -6564,6 +6582,7 @@ begin
ctdcsUnitSet: Result:=GetUnitSetIDForDirectory(ADirectory,false);
ctdcsFPCUnitPath: Result:=GetFPCUnitPathForDirectory(ADirectory,false);
ctdcsNamespaces: Result:=GetNamespacesForDirectory(ADirectory,false);
ctdcsNamespacedIncludes: Result:=GetNamespacedIncludesForDirectory(ADirectory,false);
else RaiseCatchableException(''){%H-};
end;
end;

11
components/codetools/definetemplates.pas
View File

@ -73,6 +73,7 @@ const
StdDefTemplLazarusSrcDir = 'Lazarus source directory';
StdDefTemplLazarusBuildOpts = 'Lazarus build options';
StdDefTemplLCLProject = 'LCL project';
StdDefTemplCodetoolsFPCSrc = 'CodetoolsFPCSrc';
// Standard macros
DefinePathMacroName = ExternalMacroStart+'DefinePath'; // the current directory
@ -2552,11 +2553,17 @@ begin
Format(ctsFreePascalSourcesPlusDesc,['RTL, FCL, Packages, Compiler']),
'','',da_Block);
// The Free Pascal sources build a world of their own
// => reset all search paths
MainDir:=TDefineTemplate.Create('Free Pascal Source Directory',
ctsFreePascalSourceDir,'',FPCSrcDir,da_Directory);
Result.AddChild(MainDir);
// add define
DefTempl:=TDefineTemplate.Create(StdDefTemplCodetoolsFPCSrc,
StdDefTemplCodetoolsFPCSrc,StdDefTemplCodetoolsFPCSrc,'',da_DefineRecurse);
MainDir.AddChild(DefTempl);
// The Free Pascal sources build a world of their own
// => reset all search paths
DefTempl:=TDefineTemplate.Create('Reset SrcPath',
ctsSrcPathInitialization,SrcPathMacroName,'',da_DefineRecurse);
MainDir.AddChild(DefTempl);

74
components/codetools/directorycacher.pas
View File

@ -70,7 +70,8 @@ type
ctdcsUnitLinks,
ctdcsUnitSet,
ctdcsFPCUnitPath, // unit paths reported by FPC
ctdcsNamespaces
ctdcsNamespaces,
ctdcsNamespacedIncludes // 1 = search include file via /namespaced/ parent folder
);
TCTDirCacheStringRecord = record
@ -231,6 +232,7 @@ type
function FindIncludeFile(const IncFilename: string; AnyCase: boolean): string; override;
function FindIncludeFileInPath(IncFilename: string; AnyCase: boolean): string;
function FindIncludeFileInCleanPath(IncFilename, SearchPath: string; AnyCase: boolean): string;
function FindNamespacedIncludeFile(const IncFilename: string): string;
procedure IterateFPCUnitsInSet(const Iterate: TCTOnIterateFile);
procedure UpdateListing; override;
@ -1332,6 +1334,11 @@ begin
SearchPath:=Strings[ctdcsIncludePath];
Result:=FindIncludeFileInCleanPath(IncFilename,SearchPath,AnyCase);
if (Result='') and FilenameIsPascalUnit(IncFilename)
and (Strings[ctdcsNamespacedIncludes]<>'') then begin
Result:=FindNamespacedIncludeFile(IncFilename);
end;
end;
function TCTDirectoryCache.FindIncludeFileInCleanPath(IncFilename,
@ -1374,6 +1381,71 @@ begin
Result:='';
end;
function TCTDirectoryCache.FindNamespacedIncludeFile(const IncFilename: string
): string;
// if Direcory contains a '/namespaced/' then search IncFilename in sibling folders
// e.g. Directory='/home/user/fpcsrc/rtl/namespaced/windows/', IncFilename='wintypes.pp'
// search it in /home/user/fpcsrc/rtl/**
const
NamespacedDir = PathDelim+'namespaced'+PathDelim;
function Traverse(Cache: TCTDirectoryCache; Lvl: integer): string;
var
i: Integer;
Dir: string;
CurListing: TCTDirectoryListing;
ChildCache: TCTDirectoryCache;
begin
Dir:=ExtractFilename(Cache.Directory);
if SameText(Dir,'backup') then exit;
Result:=Cache.FindIncludeFile(IncFilename,True);
if Result<>'' then exit;
if Lvl>4 then exit;
inc(Lvl);
CurListing:=Cache.Listing;
for i:=0 to CurListing.Count-1 do begin
if CurListing.GetAttr(i) and faDirectory=0 then continue;
Dir:=Cache.Directory+CurListing.GetFilename(i);
ChildCache:=Pool.GetCache(Dir,true,false);
Result:=Traverse(ChildCache,Lvl);
if Result<>'' then exit;
end;
end;
var
p: SizeInt;
Dir, SubDir: String;
Cache: TCTDirectoryCache;
begin
Result:='';
if Pos(PathDelim,IncFilename)>0 then exit;
p:=Pos(NamespacedDir,Directory);
if p<1 then exit;
//debugln(['TCTDirectoryCache.FindNamespacedIncludeFile ',Directory,' -> ',IncFilename]);
Dir:=LeftStr(Directory,p);
SubDir:=copy(Directory,p+length(NamespacedDir),length(Directory));
if SubDir<>'' then begin
// first search in same subdir aka the directory without /namespaced/
Result:=Dir+SubDir+IncFilename;
if Pool.FileExists(Result) then
exit;
end;
// then search in subdir 'src'
Result:=Dir+'src'+IncFilename;
if Pool.FileExists(Result) then
exit;
// finally search recursively
//debugln(['TCTDirectoryCache.FindNamespacedIncludeFile Dir=',Dir,' SubDir="',SubDir,'"']);
Cache:=Pool.GetCache(Dir,true,false);
Result:=Traverse(Cache,0);
end;
function TCTDirectoryCache.FileAge(const ShortFilename: string): TCTFileAgeTime;
var
i: Integer;

4
components/codetools/fileprocs.pas
View File

@ -1191,10 +1191,10 @@ function FilenameIsMatching(const Mask, Filename: string;
var
A, B: string;
begin
SetLength(A,LenA);
SetLength(A{%H-},LenA);
if LenA>0 then
Move(AP^,A[1],LenA);
SetLength(B,LenB);
SetLength(B{%H-},LenB);
if LenB>0 then
Move(BP^,B[1],LenB);
Result:=UTF8CompareText(A,B);

39
components/codetools/tests/testfinddeclaration.pas
View File

@ -1439,12 +1439,13 @@ var
UnitSet: TFPCUnitSetCache;
FPCSrcDir: String;
procedure Traverse(Dir: string; IsNamespaced: boolean);
procedure Traverse(const Dir: string; Lvl, NamespacedLvl: integer);
var
Cache: TCTDirectoryCache;
Listing: TCTDirectoryListing;
i, p, AtomStart, IncludeStart, IncludeEnd: Integer;
CurFilename, Ext, FullFilename, Src, IncFilename, FullIncFilename: String;
i, p, AtomStart, IncludeStart, IncludeEnd, NextNamespacedLvl: Integer;
CurFilename, Ext, FullFilename, Src, IncFilename, FullIncFilename,
FoundFilename, CurUnitName, DirectiveName: String;
CurCode: TCodeBuffer;
begin
Cache:=CodeToolBoss.DirectoryCachePool.GetCache(Dir,true,false);
@ -1455,10 +1456,15 @@ var
FullFilename:=Dir+PathDelim+CurFilename;
if Listing.GetAttr(i) and faDirectory>0 then begin
// search recursive
Traverse(FullFilename,IsNamespaced or (CurFilename='namespaced'));
NextNamespacedLvl:=NamespacedLvl;
if NamespacedLvl>=0 then
inc(NextNamespacedLvl)
else if CurFilename='namespaced' then
NextNamespacedLvl:=Lvl;
Traverse(FullFilename,Lvl+1,NextNamespacedLvl);
end else begin
Ext:=ExtractFileExt(CurFilename);
if IsNamespaced and ((Ext='.pp') or (Ext='.pas')) then begin
if (NamespacedLvl>=0) and ((Ext='.pp') or (Ext='.pas')) then begin
CurCode:=CodeToolBoss.LoadFile(FullFilename,true,false);
if CurCode=nil then begin
debugln(['TTestFindDeclaration.TestFindDeclaration_FindFPCSrcNameSpacedUnits failed loading "'+FullFilename+'"']);
@ -1479,18 +1485,29 @@ var
end;
// search include directive
if not FindIncludeDirective(Src,'unit',1,IncludeStart,IncludeEnd) then begin
debugln(['TTestFindDeclaration.TestFindDeclaration_FindFPCSrcNameSpacedUnits missing include directive in "'+FullFilename+'"']);
debugln(['TTestFindDeclaration.TestFindDeclaration_FindFPCSrcNameSpacedUnits missing include directive in "'+FullFilename+'"',NamespacedLvl]);
continue;
end;
IncFilename:=copy(Src,IncludeStart,IncludeEnd-IncludeStart);
ExtractLongParamDirective(Src,IncludeStart,DirectiveName,IncFilename);
DoDirSeparators(IncFilename);
if ExtractFilePath(IncFilename)<>'' then begin
FullIncFilename:=ResolveDots(Dir+PathDelim+IncFilename);
if not FileExists(FullIncFilename) then begin
Fail('Namespaced unit "'+FullFilename+'" includes missing "'+IncFilename+'"');
if not CodeToolBoss.DirectoryCachePool.FileExists(FullIncFilename) then begin
Fail('[20231230132715] Namespaced unit "'+FullFilename+'" includes missing "'+IncFilename+'"');
end;
end else begin
//debugln(['Namespaced unit "'+FullFilename+'" has include "'+IncFilename+'", searching ...']);
FoundFilename:=CodeToolBoss.DirectoryCachePool.FindIncludeFileInCompletePath(Dir,IncFilename);
if FoundFilename<>'' then continue;
if not FilenameIsPascalUnit(IncFilename) then begin
Fail('[20231230132721] Namespaced unit "'+FullFilename+'" includes missing "'+IncFilename+'"');
end;
CurUnitName:=ExtractFileNameOnly(IncFilename);
FoundFilename:=CodeToolBoss.DirectoryCachePool.FindUnitInUnitLinks('',CurUnitName);
if FoundFilename<>'' then begin
Fail('Namespaced unit "'+FullFilename+'" includes file "'+IncFilename+'", not found via FindIncludeFileInCompletePath, but found via UnitLinks');
end else begin
debugln('Note: Namespaced unit "'+FullFilename+'" includes missing file "'+IncFilename+'"');
end;
end;
end;
end;
@ -1504,7 +1521,7 @@ begin
if FPCSrcDir='' then Fail('UnitSet.FPCSourceDirectory empty');
if not DirectoryExists(FPCSrcDir) then
Fail('UnitSet.FPCSourceDirectory not found: "'+FPCSrcDir+'"');
Traverse(FPCSrcDir,false);
Traverse(FPCSrcDir,0,-1);
end;
procedure TTestFindDeclaration.TestFindDeclaration_DirectiveWithIn;