codetools: searching fpc source namespaced includes, issue #40670

components/codetools/codetoolmanager.pas

@@ -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;

components/codetools/definetemplates.pas

@@ -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);

components/codetools/directorycacher.pas

@@ -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;

components/codetools/fileprocs.pas

@@ -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);

components/codetools/tests/testfinddeclaration.pas

@@ -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;
+    i, p, AtomStart, IncludeStart, IncludeEnd, NextNamespacedLvl: Integer;
-    CurFilename, Ext, FullFilename, Src, IncFilename, FullIncFilename: String;
+    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
+            if not CodeToolBoss.DirectoryCachePool.FileExists(FullIncFilename) then begin
-              Fail('Namespaced unit "'+FullFilename+'" includes missing "'+IncFilename+'"');
+              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;