ideconfig: added RelateDirectoryMasks and tests

ide/packages/ideconfig/searchpathprocs.pas

@@ -1,6 +1,31 @@
+{
+  Functions for search paths maintained by the IDE, e.g. UnitPaths, IncludePath.
+
+  The Lazarus IDE has some special rules for search paths:
+  - Search paths are separated by semicolon
+  - It uses TrimAndExpandFilename to trim leading and trailing spaces and expand ~ on Unix
+  - It uses ResolveDots to normalize e.g. /foo/../bar to /bar and merges // to /
+  - It normalizes AllowDirectorySeparators to PathDelim
+  - A $(macro) at start is treated as an absolute filename
+  - Star directories:
+    /path/* matches all direct sub directories  /path/* (similar to fpc)
+    /path/** matches all sub directories  /path/**
+}
 unit SearchPathProcs;
 
 {$mode objfpc}{$H+}
+{$ScopedEnums on}
+{$ModeSwitch advancedrecords}
+
+{$IF defined(Windows) or defined(darwin) or defined(HASAMIGA)}
+{$define CaseInsensitiveFilenames}
+{$IFDEF Windows}
+  {$define HasUNCPaths}
+{$ENDIF}
+{$ENDIF}
+{$IF defined(CaseInsensitiveFilenames)}
+  {$define NotLiteralFilenames} // e.g. HFS+ normalizes file names
+{$ENDIF}
 
 interface
 
@@ -9,6 +34,32 @@ uses
   // LazUtils
   LazFileUtils, LazFileCache, FileUtil;
 
+type
+  TSPMaskType = (
+    None,
+    Star, // matching all direct sub directories  /path/*
+    StarStar // matching all sub directories  /path/**
+    );
+
+  TSPFileMaskRelation = (
+    None,
+    Equal,
+    LeftMoreGeneral, // e.g. left is * and right is path
+    RightMoreGeneral // e.g. right is ** and left is *
+    );
+
+  { TSPMaskRecord }
+
+  TSPMaskRecord = record
+    Len: integer;
+    StartPos: PChar;
+    EndPos: PChar;
+    PathDelimCount: integer;
+    LastPathDelim: PChar; // nil if no pathdelim
+    MaskType: TSPMaskType;
+    function FindPathDelim(Index: integer{starting at 1}): PChar;
+  end;
+
 // search paths
 function TrimSearchPath(const SearchPath, BaseDirectory: string;
                   DeleteDoubles: boolean = false; ExpandPaths: boolean = false): string;
@@ -30,6 +81,14 @@ function SearchDirectoryInSearchPath(const SearchPath, Directory: string;
                                      DirStartPos: integer = 1): integer;
 function SearchDirectoryInSearchPath(SearchPath: TStrings;
                     const Directory: string; DirStartPos: integer = 0): integer;
+function FilenamePIsAbsolute(TheFilename: PChar): boolean;
+function FilenamePIsUnixAbsolute(TheFilename: PChar): boolean;
+function FilenamePIsWinAbsolute(TheFilename: PChar): boolean;
+
+function RelateDirectoryMasks(const LeftDir: string; LeftStart: integer; const RightDir: string; RightStart: integer): TSPFileMaskRelation;
+function GetSPMaskRecord(const aDirectory: string; aStartPos: integer; out MaskRecord: TSPMaskRecord): boolean;
+
+function dbgs(r: TSPFileMaskRelation): string; overload;
 
 implementation
 
@@ -485,5 +544,181 @@ begin
   end;
 end;
 
+function FilenamePIsAbsolute(TheFilename: PChar): boolean;
+begin
+  {$IFDEF Unix}
+  Result:=FilenamePIsUnixAbsolute(TheFilename);
+  {$ELSE}
+  Result:=FilenamePIsWinAbsolute(TheFilename);
+  {$ENDIF}
+end;
+
+function FilenamePIsUnixAbsolute(TheFilename: PChar): boolean;
+begin
+  Result:=(TheFilename<>nil) and (TheFilename^='/');
+end;
+
+function FilenamePIsWinAbsolute(TheFilename: PChar): boolean;
+begin
+  if TheFilename=nil then exit(false);
+  {$ifdef wince}
+  Result := TheFilename^ in AllowDirectorySeparators;
+  {$else wince}
+  Result:=(TheFilename^ in ['A'..'Z','a'..'z']) and (TheFilename[1]=':')
+           and (TheFilename[2] in AllowDirectorySeparators)
+      or ((TheFilename^ in AllowDirectorySeparators) and (TheFilename^=TheFilename[1]));
+  {$endif wince}
+end;
+
+function RelateDirectoryMasks(const LeftDir: string; LeftStart: integer;
+  const RightDir: string; RightStart: integer): TSPFileMaskRelation;
+var
+  Left, Right: TSPMaskRecord;
+begin
+  Result:=TSPFileMaskRelation.None;
+
+  if not GetSPMaskRecord(LeftDir,LeftStart,Left) then exit;
+  if not GetSPMaskRecord(RightDir,RightStart,Right) then exit;
+
+  if FilenamePIsAbsolute(Left.StartPos)<>FilenamePIsAbsolute(Right.StartPos) then
+    exit; // absolute and relative path don't match
+
+  if Left.MaskType=Right.MaskType then
+  begin
+    // same mask type -> simple compare
+    if CompareFilenames(Left.StartPos,Left.Len,Right.StartPos,Right.Len)=0 then
+      Result:=TSPFileMaskRelation.Equal;
+    exit;
+  end;
+
+  // different mask types
+  if Left.MaskType=TSPMaskType.StarStar then
+  begin
+    // e.g. Left is /foo/** and Right is /bar or /bar/*
+    if (Left.PathDelimCount<=Right.PathDelimCount) then
+    begin
+      if (Left.PathDelimCount=0)
+          or (CompareFilenames(Left.StartPos,Left.LastPathDelim-1-Left.StartPos,
+                      Right.StartPos,Right.FindPathDelim(Left.PathDelimCount)-1-Right.StartPos)=0) then
+        Result:=TSPFileMaskRelation.LeftMoreGeneral;
+    end;
+    exit;
+  end;
+  if Right.MaskType=TSPMaskType.StarStar then
+  begin
+    // e.g. Left is /foo or /foo/* and Right is /bar/**
+    if Left.PathDelimCount>=Right.PathDelimCount then
+    begin
+      if (Right.PathDelimCount=0)
+            or (CompareFilenames(Left.StartPos,Left.FindPathDelim(Right.PathDelimCount)-1-Left.StartPos,
+                                 Right.StartPos,Right.LastPathDelim-1-Right.StartPos)=0) then
+      Result:=TSPFileMaskRelation.RightMoreGeneral;
+    end;
+    exit;
+  end;
+  // Left or Right is a /bar/* and the other has no star
+  if (Left.PathDelimCount=Right.PathDelimCount) then
+  begin
+    if (Left.PathDelimCount=0)
+        or (CompareFilenames(Left.StartPos,Left.LastPathDelim-1-Left.StartPos,
+                    Right.StartPos,Right.LastPathDelim-1-Right.StartPos)=0) then
+    begin
+      if Left.MaskType=TSPMaskType.Star then
+        Result:=TSPFileMaskRelation.LeftMoreGeneral
+      else
+        Result:=TSPFileMaskRelation.RightMoreGeneral;
+    end;
+  end;
+end;
+
+function GetSPMaskRecord(const aDirectory: string; aStartPos: integer; out
+  MaskRecord: TSPMaskRecord): boolean;
+begin
+  Result:=false;
+  MaskRecord:=Default(TSPMaskRecord);
+  with MaskRecord do begin
+    if aStartPos>length(aDirectory) then
+      exit;
+    StartPos:=@aDirectory[aStartPos];
+    EndPos:=StartPos;
+
+    repeat
+      case EndPos^ of
+      #0,';': break;
+      PathDelim:
+        begin
+          inc(PathDelimCount);
+          LastPathDelim:=EndPos;
+        end;
+      end;
+      inc(EndPos);
+    until false;
+    Len:=EndPos-StartPos;
+    if Len=0 then exit;
+
+    // ignore trailing pathdelim
+    if EndPos[-1]=PathDelim then
+    begin
+      dec(EndPos);
+      dec(PathDelimCount);
+      if PathDelimCount=0 then
+        LastPathDelim:=nil
+      else begin
+        dec(LastPathDelim);
+        while LastPathDelim^<>PathDelim do dec(LastPathDelim);
+      end;
+      dec(Len);
+      if Len=0 then exit;
+    end;
+
+    if EndPos[-1]='*' then
+    begin
+      if (LastPathDelim=nil) then
+      begin
+        if Len=1 then
+          MaskType:=TSPMaskType.Star
+        else if (Len=2) and (StartPos^='*') then
+          MaskType:=TSPMaskType.StarStar;
+      end else begin
+        if EndPos-2=LastPathDelim then
+          MaskType:=TSPMaskType.Star
+        else if (EndPos-3=LastPathDelim) and (LastPathDelim[1]='*') then
+          MaskType:=TSPMaskType.StarStar;
+      end;
+    end;
+  end;
+  Result:=true;
+end;
+
+function dbgs(r: TSPFileMaskRelation): string;
+begin
+  case r of
+    TSPFileMaskRelation.Equal: Result:='Equal';
+    TSPFileMaskRelation.LeftMoreGeneral: Result:='LeftMoreGeneral';
+    TSPFileMaskRelation.RightMoreGeneral: Result:='RightMoreGeneral';
+  else
+    Result:='None';
+  end;
+end;
+
+{ TSPMaskRecord }
+
+function TSPMaskRecord.FindPathDelim(Index: integer): PChar;
+begin
+  Result:=StartPos;
+  if (Result=nil) or (Index<1) then exit;
+  while Result<EndPos do
+  begin
+    if Result^=PathDelim then
+    begin
+      if Index=1 then
+        exit;
+      dec(Index);
+    end;
+    inc(Result);
+  end;
+  Result:=nil;
+end;
+
 end.
 

test/.gitignore

@@ -0,0 +1 @@
+runtests

test/ideintf/testsearchpathprocs.pas

@@ -0,0 +1,108 @@
+{
+ Test all with:
+     ./runtests --format=plain --suite=TTestSearchPathProcs
+
+ Test specific with:
+     ./runtests --format=plain --suite=TTestSearchPathProcs.TestRelateDirectoryMasks
+}
+unit TestSearchPathProcs;
+
+{$mode ObjFPC}{$H+}
+
+interface
+
+uses
+  Classes, SysUtils, Types, fpcunit, testglobals, LazLogger, LazFileUtils,
+  SearchPathProcs, LazUTF8;
+
+type
+
+  { TTestSearchPathProcs }
+
+  TTestSearchPathProcs = class(TTestCase)
+  published
+    procedure TestRelateDirectoryMasks;
+  end;
+
+implementation
+
+{ TTestSearchPathProcs }
+
+procedure TTestSearchPathProcs.TestRelateDirectoryMasks;
+
+  procedure t(const Paths: TStringDynArray; Left, Right: integer; Expected: TSPFileMaskRelation);
+  var
+    SearchPath: String;
+    i, LeftStart, RightStart: Integer;
+    Actual: TSPFileMaskRelation;
+  begin
+    SearchPath:='';
+    LeftStart:=10000;
+    RightStart:=10000;
+    for i:=0 to length(Paths)-1 do begin
+      if i>0 then
+        SearchPath+=';';
+      if i=Left then
+        LeftStart:=length(SearchPath)+1;
+      if i=Right then
+        RightStart:=length(SearchPath)+1;
+      SearchPath+=Paths[i];
+    end;
+
+    Actual:=RelateDirectoryMasks(SearchPath,LeftStart,SearchPath,RightStart);
+    if Actual<>Expected then begin
+      Fail('SearchPath="'+SearchPath+'" LeftStart='+IntToStr(LeftStart)+' RightStart='+IntToStr(RightStart)+' Actual='+dbgs(Actual)+' Expected='+dbgs(Expected));
+    end;
+
+    // try the other way round
+    case Expected of
+      TSPFileMaskRelation.LeftMoreGeneral: Expected:=TSPFileMaskRelation.RightMoreGeneral;
+      TSPFileMaskRelation.RightMoreGeneral: Expected:=TSPFileMaskRelation.LeftMoreGeneral;
+    end;
+    Actual:=RelateDirectoryMasks(SearchPath,RightStart,SearchPath,LeftStart);
+    if Actual<>Expected then begin
+      Fail('SearchPath="'+SearchPath+'" LeftStart='+IntToStr(LeftStart)+' RightStart='+IntToStr(RightStart)+' Actual='+dbgs(Actual)+' Expected='+dbgs(Expected));    end;
+  end;
+
+begin
+  t([''],1,1,TSPFileMaskRelation.None);
+  t([''],0,0,TSPFileMaskRelation.None);
+  t(['a'],0,0,TSPFileMaskRelation.Equal);
+  t(['foo'],0,0,TSPFileMaskRelation.Equal);
+  t(['/foo'],0,0,TSPFileMaskRelation.Equal);
+  t(['/foo/bar'],0,0,TSPFileMaskRelation.Equal);
+  t(['/foo/bar','/foo/bar/'],0,1,TSPFileMaskRelation.Equal);
+
+  // star
+  t(['*'],0,0,TSPFileMaskRelation.Equal);
+  t(['/*'],0,0,TSPFileMaskRelation.Equal);
+  t(['/foo/*'],0,0,TSPFileMaskRelation.Equal);
+  t(['*','a'],0,1,TSPFileMaskRelation.LeftMoreGeneral);
+  t(['*','a/'],0,1,TSPFileMaskRelation.LeftMoreGeneral);
+  t(['/*','/a'],0,1,TSPFileMaskRelation.LeftMoreGeneral);
+  t(['/*','a'],0,1,TSPFileMaskRelation.None);
+  t(['/foo/*','/foo/a'],0,1,TSPFileMaskRelation.LeftMoreGeneral);
+  t(['/foo/*','/foo/a/'],0,1,TSPFileMaskRelation.LeftMoreGeneral);
+  t(['foo/*','foo/a'],0,1,TSPFileMaskRelation.LeftMoreGeneral);
+  t(['/foo/*','/a'],0,1,TSPFileMaskRelation.None);
+  t(['foo/*','a'],0,1,TSPFileMaskRelation.None);
+  t(['/foo/*','/foo/bar/a'],0,1,TSPFileMaskRelation.None);
+  t(['foo/*','foo/bar/a'],0,1,TSPFileMaskRelation.None);
+
+  // star star
+  t(['**'],0,0,TSPFileMaskRelation.Equal);
+  t(['/**'],0,0,TSPFileMaskRelation.Equal);
+  t(['/bar/**'],0,0,TSPFileMaskRelation.Equal);
+  t(['**','a'],0,1,TSPFileMaskRelation.LeftMoreGeneral);
+  t(['**','foo/a'],0,1,TSPFileMaskRelation.LeftMoreGeneral);
+  t(['**','/foo/a'],0,1,TSPFileMaskRelation.None);
+  t(['/**','foo/a'],0,1,TSPFileMaskRelation.None);
+  t(['/foo/**','foo/a'],0,1,TSPFileMaskRelation.None);
+  t(['/foo/**','/foo/a'],0,1,TSPFileMaskRelation.LeftMoreGeneral);
+  t(['/foo/**','/foo/bar/a'],0,1,TSPFileMaskRelation.LeftMoreGeneral);
+end;
+
+initialization
+  AddToIDEIntfTestSuite(TTestSearchPathProcs);
+end.
+

test/runtests.lpi

@@ -1,14 +1,14 @@
 <?xml version="1.0" encoding="UTF-8"?>
 <CONFIG>
   <ProjectOptions>
-    <Version Value="10"/>
+    <Version Value="12"/>
     <PathDelim Value="\"/>
     <General>
       <Flags>
         <LRSInOutputDirectory Value="False"/>
+        <CompatibilityMode Value="True"/>
       </Flags>
       <SessionStorage Value="InIDEConfig"/>
-      <MainUnit Value="0"/>
     </General>
     <BuildModes Count="2">
       <Item1 Name="default" Default="True"/>
@@ -23,11 +23,11 @@
             <Filename Value="runtests"/>
           </Target>
           <SearchPaths>
-            <OtherUnitFiles Value="bugs;lcltests;lazutils"/>
+            <OtherUnitFiles Value="bugs;lcltests;lazutils;ideintf"/>
             <UnitOutputDirectory Value="unitsconsole\$(TargetCPU)-$(TargetOS)"/>
           </SearchPaths>
           <Conditionals Value="if defined(EnableCTRange) then
-  CustomOptions += '-dEnableCTRange';"/>
+  CustomOptions += &apos;-dEnableCTRange&apos;;"/>
           <BuildMacros>
             <Count Value="1"/>
             <Item1>
@@ -48,6 +48,9 @@
             </Checks>
           </CodeGeneration>
           <Other>
+            <ConfigFile>
+              <WriteConfigFilePath Value="$(ProjOutDir)\fpclaz.cfg"/>
+            </ConfigFile>
             <CustomOptions Value="-dNoSemiAutomatedTests"/>
           </Other>
         </CompilerOptions>
@@ -58,34 +61,43 @@
     </BuildModes>
     <PublishOptions>
       <Version Value="2"/>
-      <IncludeFileFilter Value="*.(pas|pp|inc|lfm|lpr|lrs|lpi|lpk|sh|xml)"/>
-      <ExcludeFileFilter Value="*.(bak|ppu|ppw|o|so);*~;backup"/>
     </PublishOptions>
     <RunParams>
       <local>
-        <FormatVersion Value="1"/>
         <CommandLineParams Value="-s bugs.2068 --file=results.xml"/>
-        <LaunchingApplication PathPlusParams="\usr\X11R6\bin\xterm -T 'Lazarus Run Output' -e $(LazarusDir)\tools\runwait.sh $(TargetCmdLine)"/>
+        <LaunchingApplication PathPlusParams="\usr\X11R6\bin\xterm -T &apos;Lazarus Run Output&apos; -e $(LazarusDir)\tools\runwait.sh $(TargetCmdLine)"/>
       </local>
+      <FormatVersion Value="2"/>
+      <Modes Count="1">
+        <Mode0 Name="default">
+          <local>
+            <CommandLineParams Value="-s bugs.2068 --file=results.xml"/>
+            <LaunchingApplication PathPlusParams="\usr\X11R6\bin\xterm -T &apos;Lazarus Run Output&apos; -e $(LazarusDir)\tools\runwait.sh $(TargetCmdLine)"/>
+          </local>
+        </Mode0>
+      </Modes>
     </RunParams>
-    <RequiredPackages Count="5">
+    <RequiredPackages Count="6">
       <Item1>
-        <PackageName Value="CodeTools"/>
+        <PackageName Value="IdeConfig"/>
       </Item1>
       <Item2>
-        <PackageName Value="FCL"/>
+        <PackageName Value="CodeTools"/>
       </Item2>
       <Item3>
-        <PackageName Value="LCL"/>
+        <PackageName Value="FCL"/>
       </Item3>
       <Item4>
-        <PackageName Value="fpcunitconsolerunner"/>
+        <PackageName Value="LCL"/>
       </Item4>
       <Item5>
-        <PackageName Value="lazmouseandkeyinput"/>
+        <PackageName Value="fpcunitconsolerunner"/>
       </Item5>
+      <Item6>
+        <PackageName Value="lazmouseandkeyinput"/>
+      </Item6>
     </RequiredPackages>
-    <Units Count="13">
+    <Units Count="14">
       <Unit0>
         <Filename Value="runtests.lpr"/>
         <IsPartOfProject Value="True"/>
@@ -144,6 +156,11 @@
         <IsPartOfProject Value="True"/>
         <UnitName Value="TestLazFileUtils"/>
       </Unit12>
+      <Unit13>
+        <Filename Value="ideintf\testsearchpathprocs.pas"/>
+        <IsPartOfProject Value="True"/>
+        <UnitName Value="TestSearchPathProcs"/>
+      </Unit13>
     </Units>
   </ProjectOptions>
   <CompilerOptions>
@@ -153,11 +170,11 @@
       <Filename Value="runtests"/>
     </Target>
     <SearchPaths>
-      <OtherUnitFiles Value="bugs;lcltests;lazutils"/>
+      <OtherUnitFiles Value="bugs;lcltests;lazutils;ideintf"/>
       <UnitOutputDirectory Value="units\$(TargetCPU)-$(TargetOS)"/>
     </SearchPaths>
     <Conditionals Value="if defined(EnableCTRange) then
-  CustomOptions += '-dEnableCTRange';"/>
+  CustomOptions += &apos;-dEnableCTRange&apos;;"/>
     <BuildMacros>
       <Count Value="1"/>
       <Item1>
@@ -179,6 +196,9 @@
       </Checks>
     </CodeGeneration>
     <Other>
+      <ConfigFile>
+        <WriteConfigFilePath Value="$(ProjOutDir)\fpclaz.cfg"/>
+      </ConfigFile>
       <CustomOptions Value="-dNoSemiAutomatedTests"/>
     </Other>
   </CompilerOptions>

test/runtests.lpr

@@ -28,7 +28,8 @@ uses
   testglobals, testunits, dom,
   {Unit needed to set the LCL version and widget set name}
   LCLVersion, InterfaceBase, LCLPlatformDef, lazmouseandkeyinput, Interfaces,
-  TestLazXML, TestAvgLvlTree, TestLConvEncoding, testlazfileutils;
+  TestLazXML, TestAvgLvlTree, TestLConvEncoding, testlazfileutils, 
+TestSearchPathProcs;
   
 type
 

test/testglobals.pas

@@ -15,7 +15,7 @@
   to the Free Software Foundation, Inc., 51 Franklin Street - Fifth Floor,
   Boston, MA 02110-1335, USA.
 }
-unit testglobals;
+unit TestGlobals;
 
 {$mode objfpc}{$H+}