amicommon: massively improved FindFirst/FindNext implementation in the DOS unit. now supports Directory filtering and returns the time field of SearchRec in the expected format. This fixes a bunch of issues in the IDE and Free Vision, among others

git-svn-id: trunk@30390 -

rtl/amicommon/dos.pp

@@ -39,7 +39,8 @@ type
     { don't modify.                                          }
     { Replacement for Fill }
 {0} AnchorPtr : Pointer;    { Pointer to the Anchorpath structure }
-{4} Fill: Array[1..15] of Byte; {future use}
+{4} AttrArg: Word;          { The initial Attributes argument }
+{6} Fill: Array[1..13] of Byte; {future use}
     {End of replacement for fill}
     Attr : BYTE;        {attribute of found file}
     Time : LongInt;     {last modify date of found file}
@@ -144,6 +145,28 @@ begin
     IsLeapYear:=False;
 end;
 
+procedure AmigaDateStampToDateTime(var ds: TDateStamp; var dt: DateTime);
+var
+  cd: PClockData;
+  time: LongInt;
+begin
+  new(cd);
+  time := ds.ds_Days * (24 * 60 * 60) +
+          ds.ds_Minute * 60 +
+          ds.ds_Tick div TICKS_PER_SECOND;
+  Amiga2Date(time,cd);
+  with cd^ do
+    begin
+      dt.year:=year;
+      dt.month:=month;
+      dt.day:=mday;
+      dt.hour:=hour;
+      dt.min:=min;
+      dt.sec:=sec;
+    end;
+  dispose(cd);
+end;
+
 procedure Amiga2DateStamp(Date : LongInt; var TotalDays,Minutes,Ticks: longint);
 { Converts a value in seconds past 1978 to a value in AMIGA DateStamp format }
 { Taken from SWAG and modified to work with the Amiga format - CEC           }
@@ -513,6 +536,18 @@ end;
 {******************************************************************************
                                --- Disk ---
 ******************************************************************************}
+const
+  PROC_WIN_DISABLE = Pointer(-1);
+  PROC_WIN_WB      = Pointer(0);
+
+function SetProcessWinPtr(p: Pointer): Pointer; inline;
+var
+  MyProc: PProcess;
+begin
+  MyProc := PProcess(FindTask(Nil));
+  SetProcessWinPtr := MyProc^.pr_WindowPtr;
+  MyProc^.pr_WindowPtr := p;
+end;
 
 {
   The Diskfree and Disksize functions need a file on the specified drive, since this
@@ -617,14 +652,11 @@ function DiskSize(Drive: AnsiString): Int64;
 var
   DirLock: LongInt;
   Inf: TInfoData;
-  MyProc: PProcess;
   OldWinPtr: Pointer;
 begin
   DiskSize := -1;
   //
-  MyProc := PProcess(FindTask(Nil));
-  OldWinPtr := MyProc^.pr_WindowPtr;
-  MyProc^.pr_WindowPtr := Pointer(-1);
+  OldWinPtr:=SetProcessWinPtr(PROC_WIN_DISABLE);
   //
   DirLock := Lock(PChar(Drive), SHARED_LOCK);
   if DirLock <> 0 then
@@ -633,8 +665,7 @@ begin
       DiskSize := Int64(Inf.id_NumBlocks) * Inf.id_BytesPerBlock;
     UnLock(DirLock);
   end;
-  if OldWinPtr <> Pointer(-1) then
-    MyProc^.pr_WindowPtr := OldWinPtr;
+  SetProcessWinPtr(OldWinPtr);
 end;
 
 function DiskSize(Drive: Byte): Int64;
@@ -651,14 +682,11 @@ function DiskFree(Drive: AnsiString): Int64;
 var
   DirLock: LongInt;
   Inf: TInfoData;
-  MyProc: PProcess;
   OldWinPtr: Pointer;
 begin
   DiskFree := -1;
   //
-  MyProc := PProcess(FindTask(Nil));
-  OldWinPtr := MyProc^.pr_WindowPtr;
-  MyProc^.pr_WindowPtr := Pointer(-1);
+  OldWinPtr:=SetProcessWinPtr(PROC_WIN_DISABLE);
   //
   DirLock := Lock(PChar(Drive), SHARED_LOCK);
   if DirLock <> 0 then
@@ -667,8 +695,7 @@ begin
       DiskFree := Int64(Inf.id_NumBlocks - Inf.id_NumBlocksUsed) * Inf.id_BytesPerBlock;
     UnLock(DirLock);
   end;
-  if OldWinPtr <> Pointer(-1) then
-    MyProc^.pr_WindowPtr := OldWinPtr;
+  SetProcessWinPtr(OldWinPtr);
 end;
 
 function DiskFree(Drive: Byte): Int64;
@@ -679,42 +706,48 @@ begin
   DiskFree := DiskFree(DeviceList[Drive]);
 end;
 
-procedure FindFirst(const Path: PathStr; Attr: Word; Var f: SearchRec);
+procedure FindMatch(Result: LongInt; var f: SearchRec);
 var
- tmpStr: array[0..255] of Char;
- Anchor: PAnchorPath;
- Result: LongInt;
+  quit: boolean;
+  dt: DateTime;
 begin
-  tmpStr:=PathConv(path)+#0;
   DosError:=0;
+  quit:=false;
+  while not quit do
+    begin
+      if Result = ERROR_NO_MORE_ENTRIES then
+        DosError:=18
+      else
+        if Result<>0 then DosError:=3;
+      if DosError=0 then
+        begin
+          { if we're not looking for a directory, but we found one, try to skip it }
+          if ((f.AttrArg and Directory) = 0) and (PAnchorPath(f.AnchorPtr)^.ap_Info.fib_DirEntryType > 0) then
+            Result:=MatchNext(f.AnchorPtr)
+          else
+            quit:=true;
+        end
+      else
+        quit:=true;
+    end;
 
-  new(Anchor);
-  FillChar(Anchor^,sizeof(TAnchorPath),#0);
+  if DosError=0 then begin
+    { Fill up the Searchrec information     }
+    { and also check if the files are with  }
+    { the correct attributes                }
+    with PAnchorPath(f.AnchorPtr)^.ap_Info do begin
 
-  Result:=MatchFirst(@tmpStr,Anchor);
-  f.AnchorPtr:=Anchor;
-  if Result = ERROR_NO_MORE_ENTRIES then
-    DosError:=18
-  else
-    if Result<>0 then DosError:=3;
+      { Convert Amiga DateStamp to DOS file time }
+      AmigaDateStampToDateTime(fib_Date,dt);
+      PackTime(dt,f.time);
 
-  if DosError=0 then begin
-    {-------------------------------------------------------------------}
-    { Here we fill up the SearchRec attribute, but we also do check     }
-    { something else, if the it does not match the mask we are looking  }
-    { for we should go to the next file or directory.                   }
-    {-------------------------------------------------------------------}
-    with Anchor^.ap_Info do begin
-      f.Time := fib_Date.ds_Days * (24 * 60 * 60) +
-                fib_Date.ds_Minute * 60 +
-                fib_Date.ds_Tick div 50;
       f.attr := 0;
       {*------------------------------------*}
       {* Determine if is a file or a folder *}
       {*------------------------------------*}
-      if fib_DirEntryType>0 then f.attr:=f.attr OR DIRECTORY;
+      if fib_DirEntryType > 0 then f.attr:=f.attr OR DIRECTORY;
 
-      {*------------------------------------*}
+      {*------------------------------------* }
       {* Determine if Read only             *}
       {*  Readonly if R flag on and W flag  *}
       {*   off.                             *}
@@ -729,47 +762,27 @@ begin
   end;
 end;
 
-
-procedure FindNext(Var f: SearchRec);
+procedure FindFirst(const Path: PathStr; Attr: Word; Var f: SearchRec);
 var
- Result: longint;
+ tmpStr: array[0..255] of Char;
  Anchor: PAnchorPath;
 begin
-  DosError:=0;
-  Result:=MatchNext(f.AnchorPtr);
-  if Result = ERROR_NO_MORE_ENTRIES then
-    DosError:=18
-  else
-    if Result <> 0 then DosError:=3;
+  tmpStr:=PathConv(path)+#0;
 
-  if DosError=0 then begin
-    { Fill up the Searchrec information     }
-    { and also check if the files are with  }
-    { the correct attributes                }
-    Anchor:=pAnchorPath(f.AnchorPtr);
-    with Anchor^.ap_Info do begin
-      f.Time := fib_Date.ds_Days * (24 * 60 * 60) +
-                fib_Date.ds_Minute * 60 +
-                fib_Date.ds_Tick div 50;
-      f.attr := 0;
-      {*------------------------------------*}
-      {* Determine if is a file or a folder *}
-      {*------------------------------------*}
-      if fib_DirEntryType > 0 then f.attr:=f.attr OR DIRECTORY;
+  new(Anchor);
+  FillChar(Anchor^,sizeof(TAnchorPath),#0);
 
-      {*------------------------------------*}
-      {* Determine if Read only             *}
-      {*  Readonly if R flag on and W flag  *}
-      {*   off.                             *}
-      {* Should we check also that EXEC     *}
-      {* is zero? for read only?            *}
-      {*------------------------------------*}
-      if ((fib_Protection and FIBF_READ) <> 0) and
-         ((fib_Protection and FIBF_WRITE) = 0) then f.attr:=f.attr or READONLY;
-      f.Name := strpas(fib_FileName);
-      f.Size := fib_Size;
-    end; { end with }
-  end;
+  f.AnchorPtr:=Anchor;
+  f.AttrArg:=Attr;
+
+  FindMatch(MatchFirst(@tmpStr,Anchor),f);
+end;
+
+procedure FindNext(Var f: SearchRec);
+var
+ Result: longint;
+begin
+  FindMatch(MatchNext(f.AnchorPtr),f);
 end;
 
 procedure FindClose(Var f: SearchRec);