pastojs: searching units in current module directory, Delphi compatibility

git-svn-id: trunk@41149 -

packages/fcl-passrc/src/pasresolver.pp

@@ -21217,10 +21217,11 @@ begin
         begin
           if NumberIsFloat(TPrimitiveExpr(El).Value) then
             bt:=BaseTypeExtended
-          else if length(TPrimitiveExpr(El).Value)<10 then
+          else if length(TPrimitiveExpr(El).Value)<9 then
             bt:=btLongint
           else
             begin
+            // with 9+ it could be longword: e.g. $87654321
             Value:=Eval(TPrimitiveExpr(El),[]);
             if Value=nil then
               RaiseNotYetImplemented(20190130162601,El);

packages/pastojs/src/pas2jscompiler.pp

@@ -577,7 +577,7 @@ type
     // Command-line option handling
     procedure HandleOptionPCUFormat(aValue: String); virtual;
     function HandleOptionPaths(C: Char; aValue: String; FromCmdLine: Boolean): Boolean; virtual;
-    function HandleOptionJS(C: Char; aValue: String; Quick,FromCmdLine: Boolean): Boolean; virtual;
+    function HandleOptionJ(C: Char; aValue: String; Quick,FromCmdLine: Boolean): Boolean; virtual;
     procedure HandleOptionConfigFile(aPos: Integer; const aFileName: string); virtual;
     procedure HandleOptionInfo(aValue: string);
     // DoWriteJSFile: return false to use the default write function.
@@ -633,7 +633,7 @@ type
     function IsDefined(const aName: String): boolean;
     procedure SetOption(Flag: TP2jsCompilerOption; Enable: boolean);
 
-    function GetUnitInfo(const UseUnitName, InFileName: String;
+    function GetUnitInfo(const UseUnitName, InFileName, ModuleDir: String;
       PCUSupport: TPCUSupport): TFindUnitInfo;
     function FindFileWithUnitFilename(UnitFilename: string): TPas2jsCompilerFile;
     procedure LoadModuleFile(UnitFilename, UseUnitName: string;
@@ -1624,6 +1624,7 @@ var
   aFile: TPas2jsCompilerFile;
   UnitInfo: TFindUnitInfo;
   LoadInfo: TLoadUnitInfo;
+  ModuleDir: String;
 begin
   Result:=nil;
   aFile:=Nil;
@@ -1631,7 +1632,8 @@ begin
   if CompareText(ExtractFilenameOnly(UnitFilename),UseUnitname)=0 then
     Parser.RaiseParserError(nUnitCycle,[UseUnitname]);
 
-  UnitInfo:=Compiler.GetUnitInfo(UseUnitName,InFileName,PCUSupport);
+  ModuleDir:=ExtractFilePath(PasFileName);
+  UnitInfo:=Compiler.GetUnitInfo(UseUnitName,InFileName,ModuleDir,PCUSupport);
   if UnitInfo.FileName<>'' then
     begin
     LoadInfo.UseFilename:=UnitInfo.FileName;
@@ -1657,8 +1659,6 @@ begin
   // if Result=nil resolver will give a nice error position, so don't do it here
 end;
 
-
-
 { TPas2jsCompiler }
 
 procedure TPas2jsCompiler.SetFS(AValue: TPas2jsFS);
@@ -3025,7 +3025,7 @@ begin
 
 end;
 
-function TPas2jsCompiler.HandleOptionJS(C: Char; aValue: String;
+function TPas2jsCompiler.HandleOptionJ(C: Char; aValue: String;
   Quick, FromCmdLine: Boolean): Boolean;
 
 Var
@@ -3422,7 +3422,7 @@ begin
             UnknownParam;
           c:=aValue[1];
           Delete(aValue,1,1);
-          if not HandleOptionJS(c,aValue,Quick,FromCmdLine) then
+          if not HandleOptionJ(c,aValue,Quick,FromCmdLine) then
             UnknownParam;
         end;
       'M': // syntax mode
@@ -4657,8 +4657,8 @@ begin
   Result:=FMainJSFileResolved;
 end;
 
-function TPas2jsCompiler.GetUnitInfo(const UseUnitName, InFileName: String;
-  PCUSupport: TPCUSupport): TFindUnitInfo;
+function TPas2jsCompiler.GetUnitInfo(const UseUnitName, InFileName,
+  ModuleDir: String; PCUSupport: TPCUSupport): TFindUnitInfo;
 
 var
   FoundPasFilename, FoundPasUnitName: string;
@@ -4687,7 +4687,7 @@ var
         end;
       end else begin
         // search pas in unit path
-        FoundPasFilename:=FS.FindUnitFileName(TestUnitName,'',FoundPasIsForeign);
+        FoundPasFilename:=FS.FindUnitFileName(TestUnitName,'',ModuleDir,FoundPasIsForeign);
         if FoundPasFilename<>'' then
           FoundPasUnitName:=TestUnitName;
       end;
@@ -4745,7 +4745,7 @@ begin
     end;
   end else begin
     // search Pascal file with InFilename
-    FoundPasFilename:=FS.FindUnitFileName(UseUnitname,InFilename,FoundPasIsForeign);
+    FoundPasFilename:=FS.FindUnitFileName(UseUnitname,InFilename,ModuleDir,FoundPasIsForeign);
     if FoundPasFilename='' then
       exit; // an in-filename unit source is missing -> stop
     FoundPasUnitName:=ExtractFilenameOnly(InFilename);

packages/pastojs/src/pas2jsfilecache.pp

@@ -256,7 +256,7 @@ type
     function SearchLowUpCase(var Filename: string): boolean;
     function FindCustomJSFileName(const aFilename: string): String; override;
     function FindUnitJSFileName(const aUnitFilename: string): String; override;
-    function FindUnitFileName(const aUnitname, InFilename: string; out IsForeign: boolean): String; override;
+    function FindUnitFileName(const aUnitname, InFilename, ModuleDir: string; out IsForeign: boolean): String; override;
     function FindIncludeFileName(const aFilename: string): String; override;
     function AddIncludePaths(const Paths: string; FromCmdLine: boolean; out ErrorMsg: string): boolean;
     function AddUnitPaths(const Paths: string; FromCmdLine: boolean; out ErrorMsg: string): boolean;
@@ -1889,7 +1889,8 @@ begin
 end;
 
 
-function TPas2jsFilesCache.FindUnitFileName(const aUnitname, InFilename: string; out IsForeign: boolean): String;
+function TPas2jsFilesCache.FindUnitFileName(const aUnitname, InFilename,
+  ModuleDir: string; out IsForeign: boolean): String;
 var
   SearchedDirs: TStringList;
 
@@ -1925,7 +1926,7 @@ begin
         if SearchLowUpCase(Result) then exit;
       end else
       begin
-        Result:=ResolveDots(BaseDirectory+Result);
+        Result:=ResolveDots(ModuleDir+Result);
         if SearchLowUpCase(Result) then exit;
       end;
       exit('');
@@ -1940,6 +1941,10 @@ begin
         exit;
       end;
 
+    // then in ModuleDir
+    IsForeign:=false;
+    if SearchInDir(ModuleDir,Result) then exit;
+
     // then in BaseDirectory
     IsForeign:=false;
     if SearchInDir(BaseDirectory,Result) then exit;

packages/pastojs/src/pas2jsfileutils.pp

@@ -43,7 +43,9 @@ function ExpandDirectory(const aDirectory: string): string;
 function IsUNCPath(const {%H-}Path: String): Boolean;
 function ExtractUNCVolume(const {%H-}Path: String): String;
 function ExtractFileRoot(FileName: String): String;
-function TryCreateRelativePath(const Dest, Source: String;
+function TryCreateRelativePath(
+  const Dest: String; // Filename
+  const Source: String; // Directory
   UsePointDirectory: boolean; // True = return '.' for the current directory instead of ''
   AlwaysRequireSharedBaseFolder: Boolean;// true = only shorten if at least one shared folder
   out RelPath: String): Boolean;
@@ -278,8 +280,9 @@ end;
   - Dest = /foo Source = /bar AlwaysRequireSharedBaseFolder = True Result = False
   - Dest = /foo Source = /bar AlwaysRequireSharedBaseFolder = False Result = True RelPath = ../foo
 }
-function TryCreateRelativePath(const Dest, Source: String; UsePointDirectory: boolean;
-  AlwaysRequireSharedBaseFolder: Boolean; out RelPath: String): Boolean;
+function TryCreateRelativePath(const Dest: String; const Source: String;
+  UsePointDirectory: boolean; AlwaysRequireSharedBaseFolder: Boolean; out
+  RelPath: String): Boolean;
 Type
   TDirArr =  TStringArray;
 
@@ -649,7 +652,7 @@ begin
 end;
 {$ENDIF}
 
-procedure ForcePathDelims(Var FileName: string);
+procedure ForcePathDelims(var FileName: string);
 begin
   Filename:=GetForcedPathDelims(Filename);
 end;

packages/pastojs/src/pas2jsfs.pp

@@ -101,7 +101,7 @@ Type
     Function FileExists(Const aFileName: String): Boolean; virtual; abstract;
     function FindUnitJSFileName(const aUnitFilename: string): String; virtual; abstract;
     function FindCustomJSFileName(const aFilename: string): String; virtual; abstract;
-    function FindUnitFileName(const aUnitname, InFilename: string; out IsForeign: boolean): String; virtual; abstract;
+    function FindUnitFileName(const aUnitname, InFilename, ModuleDir: string; out IsForeign: boolean): String; virtual; abstract;
     procedure SaveToFile(ms: TFPJSStream; Filename: string); virtual; abstract;
     function PCUExists(var aFileName: string): Boolean; virtual;
     procedure GetPCUDirs(aList: TStrings; const aBaseDir: String); virtual;

packages/pastojs/tests/tcunitsearch.pas

@@ -135,6 +135,8 @@ type
 
   TTestCLI_UnitSearch = class(TCustomTestCLI)
   published
+    procedure TestUS_CreateRelativePath;
+
     procedure TestUS_Program;
     procedure TestUS_UsesEmptyFileFail;
     procedure TestUS_Program_o;
@@ -145,6 +147,7 @@ type
     procedure TestUS_UsesInFile;
     procedure TestUS_UsesInFile_Duplicate;
     procedure TestUS_UsesInFile_IndirectDuplicate;
+    procedure TestUS_UsesInFile_WorkNotEqProgDir;
   end;
 
 function LinesToStr(const Lines: array of string): string;
@@ -584,6 +587,49 @@ end;
 
 { TTestCLI_UnitSearch }
 
+procedure TTestCLI_UnitSearch.TestUS_CreateRelativePath;
+
+  procedure DoTest(Filename, BaseDirectory, Expected: string;
+    UsePointDirectory: boolean = false);
+  var
+    Actual: String;
+  begin
+    ForcePathDelims(Filename);
+    ForcePathDelims(BaseDirectory);
+    ForcePathDelims(Expected);
+    if not TryCreateRelativePath(Filename,BaseDirectory,UsePointDirectory,true,Actual) then
+      Actual:=Filename;
+    AssertEquals('TryCreateRelativePath(File='+Filename+',Base='+BaseDirectory+')',
+      Expected,Actual);
+  end;
+
+begin
+  DoTest('/a','/a','');
+  DoTest('/a','/a','.',true);
+  DoTest('/a','/a/','');
+  DoTest('/a/b','/a/b','');
+  DoTest('/a/b','/a/b/','');
+  DoTest('/a','/a/','');
+  DoTest('/a','','/a');
+  DoTest('/a/b','/a','b');
+  DoTest('/a/b','/a/','b');
+  DoTest('/a/b','/a//','b');
+  DoTest('/a','/a/b','..');
+  DoTest('/a','/a/b/','..');
+  DoTest('/a','/a/b//','..');
+  DoTest('/a/','/a/b','..');
+  DoTest('/a','/a/b/c','../..');
+  DoTest('/a','/a/b//c','../..');
+  DoTest('/a','/a//b/c','../..');
+  DoTest('/a','/a//b/c/','../..');
+  DoTest('/a','/b','/a');
+  DoTest('~/bin','/','~/bin');
+  DoTest('$(HOME)/bin','/','$(HOME)/bin');
+  {$IFDEF MSWindows}
+  DoTest('D:\a\b\c.pas','D:\a\d\','..\b\c.pas');
+  {$ENDIF}
+end;
+
 procedure TTestCLI_UnitSearch.TestUS_Program;
 begin
   AddUnit('system.pp',[''],['']);
@@ -707,6 +753,22 @@ begin
   AssertEquals('ErrorMsg','Duplicate file found: "'+WorkDir+'unit1.pas" and "'+WorkDir+'sub/unit1.pas"',ErrorMsg);
 end;
 
+procedure TTestCLI_UnitSearch.TestUS_UsesInFile_WorkNotEqProgDir;
+begin
+  AddUnit('system.pp',[''],['']);
+  AddUnit('sub/unit2.pas',
+  ['var a: longint;'],
+  ['']);
+  AddUnit('sub/unit1.pas',
+  ['uses unit2;'],
+  ['']);
+  AddFile('sub/test1.pas',[
+    'uses foo in ''unit1.pas'';',
+    'begin',
+    'end.']);
+  Compile(['sub/test1.pas','-Jc']);
+end;
+
 Initialization
   RegisterTests([TTestCLI_UnitSearch]);
 end.