Changes from Gretjan Schouten

rtl/dos/go32v2/filutil.inc

@@ -14,136 +14,317 @@
 
  **********************************************************************}
 
+{******************************************************************************}
+{ private functions                                                            }
+{******************************************************************************}
 
-Function FileOpen (Const FileName : string; Mode : Integer) : Longint;
+{ some internal constants }
+
+const
+   ofRead        = $0000;    { Open for reading }
+   ofWrite       = $0001;    { Open for writing }
+   ofReadWrite   = $0002;    { Open for reading/writing }
+   faFail        = $0000;    { Fail if file does not exist }
+   faCreate      = $0010;    { Create if file does not exist }
+   faOpen        = $0001;    { Open if file exists }
+   faOpenReplace = $0002;    { Clear if file exists }
+
+
+{  converts S to a pchar and copies it to the transfer-buffer.   }
+
+procedure StringToTB(const S: string);
+var P: pchar; Len: integer;
+begin
+Len := Length(S) + 1;
+P := StrPCopy(StrAlloc(Len), S);
+SysCopyToDos(longint(P), Len);
+StrDispose(P);
+end ;
+
+{  Native OpenFile function.
+   if return value <> 0 call failed.  }
+
+function OpenFile(const FileName: string; var Handle: longint; Mode, Action: word): longint;
+var
+   Regs: registers;
+begin
+result := 0;
+Handle := 0;
+StringToTB(FileName);
+if LFNSupport then Regs.Eax:=$716c
+else Regs.Eax:=$6c00;
+Regs.Edx := Action;                   { Action if file exists/not exists }
+Regs.Ds := tb_segment;
+Regs.Esi := tb_offset;
+Regs.Ebx := $2000 + (Mode and $ff);   { file open mode }
+Regs.Ecx := $20;                      { Attributes }
+RealIntr($21, Regs);
+if Regs.Flags and CarryFlag <> 0 then result := Regs.Ax
+else Handle := Regs.Eax;
+end ;
+
+{******************************************************************************}
+{ Public functions                                                             }
+{******************************************************************************}
 
+
+Function FileOpen (Const FileName : string; Mode : Integer) : Longint;
+var e: integer;
 Begin
-  //!! Needs implementing    
-end;
+e := OpenFile(FileName, result, Mode, faOpen);
+if e <> 0 then result := -1;
+end ;
 
 
 Function FileCreate (Const FileName : String) : Longint;
-
+var e: integer;
 begin
-  //!! Needs implementing    
+e := OpenFile(FileName, result, ofReadWrite, faCreate or faOpenReplace);
+if e <> 0 then result := -1;
 end;
 
 
 Function FileRead (Handle : Longint; Var Buffer; Count : longint) : Longint;
-
 begin
-  //!! Needs implementing    
+result := Do_Read(Handle, longint(@Buffer), Count);
 end;
 
 
 Function FileWrite (Handle : Longint; Var Buffer; Count : Longint) : Longint;
-
 begin
-  //!! Needs implementing    
+result := Do_Write(Handle, longint(@Buffer), Count);
 end;
 
 
-Function FileSeek (Handle,Offset,Origin : Longint) : Longint;
-
+Function FileSeek (Handle, Offset, Origin : Longint) : Longint;
+var Regs: registers;
 begin
-  //!! Needs implementing    
+Regs.Eax := $4200;
+Regs.Al := Origin;
+Regs.Edx := Lo(Offset);
+Regs.Ecx := Hi(Offset);
+Regs.Ebx := Handle;
+RealIntr($21, Regs);
+if Regs.Flags and CarryFlag <> 0 then
+   result := -1
+else begin
+   LongRec(result).Lo := Regs.Edx;
+   LongRec(result).Hi := Regs.Ecx;
+   end ;
 end;
 
 
 Procedure FileClose (Handle : Longint);
-
+var Regs: registers;
 begin
-  //!! Needs implementing    
+Regs.Eax := $3e00;
+Regs.Ebx := Handle;
+RealIntr($21, Regs);
 end;
 
 
 Function FileAge (Const FileName : String): Longint;
-
+var Handle: longint;
 begin
-  //!! Needs implementing    
+Handle := FileOpen(FileName, 0);
+if Handle <> -1 then begin
+   result := FileGetDate(Handle);
+   FileClose(Handle);
+   end
+else result := -1;
 end;
 
 
 Function FileExists (Const FileName : String) : Boolean;
-
+var Handle: longint;
 begin
-  //!! Needs implementing    
+  //!!   This can be done quicker, need to find out how
+Result := (OpenFile(FileName, Handle, ofRead, faOpen) = 0);
+if Handle <> 0 then
+   FileClose(Handle);
 end;
 
+Type PSearchrec = ^Searchrec;
+
 
 Function FindFirst (Const Path : String; Attr : Longint; Var Rslt : TSearchRec) : Longint;
 
+Var Sr : PSearchrec;
+
 begin
-  //!! Needs implementing    
+//!! Sr := New(PSearchRec);
+getmem(sr,sizeof(searchrec)); 
+Rslt.FindHandle := longint(Sr);
+DOS.FindFirst(Path, Attr, Sr^);
+result := -DosError;
+if result = 0 then begin
+   Rslt.Time := Sr^.Time;
+   Rslt.Size := Sr^.Size;
+   Rslt.Attr := Sr^.Attr;
+   Rslt.ExcludeAttr := 0;
+   Rslt.Name := Sr^.Name;
+   end ;
 end;
 
 
 Function FindNext (Var Rslt : TSearchRec) : Longint;
 
+var Sr: PSearchRec;
+
 begin
-  //!! Needs implementing    
+Sr := PSearchRec(Rslt.FindHandle);
+if Sr <> nil then begin
+   DOS.FindNext(Sr^);
+   result := -DosError;
+   if result = 0 then begin
+      Rslt.Time := Sr^.Time;
+      Rslt.Size := Sr^.Size;
+      Rslt.Attr := Sr^.Attr;
+      Rslt.ExcludeAttr := 0;
+      Rslt.Name := Sr^.Name;
+      end ;
+   end ;
 end;
 
 
 Procedure FindClose (Var F : TSearchrec);
 
+var Sr: PSearchRec;
+
 begin
-  //!! Needs implementing    
+Sr := PSearchRec(F.FindHandle);
+if Sr <> nil then
+  //!! Dispose(Sr);
+  freemem(sr,sizeof(tsearchrec));
+F.FindHandle := 0;
 end;
 
 
 Function FileGetDate (Handle : Longint) : Longint;
-
+var Regs: registers;
 begin
-  //!! Needs implementing    
+  //!! for win95 an alternative function is available.
+Regs.Ebx := Handle;
+Regs.Eax := $5700;
+RealIntr($21, Regs);
+if Regs.Flags and CarryFlag <> 0 then result := -Regs.Ax
+else begin
+   LongRec(result).Lo := Regs.Edx;
+   LongRec(result).Hi := Regs.Eax;
+   end ;
 end;
 
 
-Function FileSetDate (Handle,Age : Longint) : Longint;
-
+Function FileSetDate (Handle, Age : Longint) : Longint;
+var Regs: registers;
 begin
-  //!! Needs implementing    
+Regs.Ebx := Handle;
+Regs.Eax := $5701;
+Regs.Ecx := Lo(Age);
+Regs.Edx := Hi(Age);
+RealIntr($21, Regs);
+if Regs.Flags and CarryFlag <> 0 then result := -Regs.Ax
+else result := 0;
 end;
 
 
 Function FileGetAttr (Const FileName : String) : Longint;
+ 
+var Regs: registers;
 
 begin
-  //!! Needs implementing    
+  StringToTB(FileName);
+  Regs.Edx := tb_offset;
+  Regs.Ds := tb_segment;
+  if LFNSupport then
+    begin
+    Regs.Ax := $7143;
+    Regs.Bx := 0;
+    end
+  else
+    Regs.Ax := $4300;
+  RealIntr($21, Regs);
+  if Regs.Flags and CarryFlag <> 0 then
+    result := -1
+  else
+    result := Regs.Cx;
 end;
 
 
 Function FileSetAttr (Const Filename : String; Attr: longint) : Longint;
 
+var Regs: registers;
+
 begin
-  //!! Needs implementing    
+  StringToTB(FileName);
+  Regs.Edx := tb_offset;
+  Regs.Ds := tb_segment;
+  if LFNSupport then
+    begin
+    Regs.Ax := $7143;
+    Regs.Bx := 1;
+    end
+  else
+    Regs.Ax := $4301;
+  Regs.Cx := Attr;
+  RealIntr($21, Regs);
+  if Regs.Flags and CarryFlag <> 0 then result := -Regs.Ax
+  else result := 0;
 end;
 
 
 Function DeleteFile (Const FileName : String) : Boolean;
+ 
+var Regs: registers;
 
 begin
-  //!! Needs implementing    
+  StringToTB(FileName);
+  Regs.Edx := tb_offset;
+  Regs.Ds := tb_offset;
+  if LFNSupport then
+    Regs.Eax := $7141
+  else
+    Regs.Eax := $4100;
+  Regs.Esi := 0;
+  Regs.Ecx := 0;
+  RealIntr($21, Regs);
+  result := (Regs.Flags and CarryFlag = 0);
 end;
 
 
 Function RenameFile (Const OldName, NewName : String) : Boolean;
+ 
+var Regs: registers;
 
 begin
-  //!! Needs implementing    
+  StringToTB(OldName + #0 + NewName);
+  Regs.Edx := tb_offset;
+  Regs.Ds := tb_segment;
+  Regs.Edi := tb_offset + Length(OldName) + 1;
+  Regs.Es := tb_segment;
+  if LFNSupport then
+    Regs.Eax := $7156
+  else
+    Regs.Eax := $5600;
+  Regs.Ecx := $ff;
+  RealIntr($21, Regs);
+  result := (Regs.Flags and CarryFlag = 0);
 end;
 
 
 Function FileSearch (Const Name, DirList : String) : String;
 
 begin
-  //!! Needs implementing    
+  result := DOS.FSearch(Name, DirList);
 end;
 
 
 {
   $Log$
-  Revision 1.2  1998-10-12 08:02:16  michael
+  Revision 1.3  1998-10-15 09:39:13  michael
+  Changes from Gretjan Schouten
+
+  Revision 1.2  1998/10/12 08:02:16  michael
   wrong file committed
 
   Revision 1.1  1998/10/11 12:21:01  michael

rtl/objpas/dati.inc

@@ -406,144 +406,188 @@ end ;
 
 {   FormatDateTime formats DateTime to the given format string FormatStr   }
 
-function FormatDateTime(FormatStr: string; DateTime: TDateTime):string;
-type
-   pstring = ^string;
-const
-   AP: array[0..1] of char = 'ap';
-   TimeAMPMStrings: array[0..1] of pstring = (@TimeAMString, @TimePMString);
+function FormatDateTime(FormatStr: string; DateTime: TDateTime): string;
 var
-   i: longint;
-   current: string;
-   ch: char;
-   e: longint;
-   y, m, d, h, n, s, ms: word;
-   mDate, mTime: double; Clock12: boolean;
-begin
-mDate := Int(DateTime);
-mTime := Frac(DateTime);
-DecodeDate(mDate, y, m, d);
-DecodeTime(mTime, h, n, s, ms);
-result := '';
-Clock12 := False;
-i := 0;
-while i < length(FormatStr) do begin
-   i := i + 1;
-   if FormatStr[i] = '"' then begin
-      i := i + 1;
-      while (i < length(FormatStr)) and (FormatStr[i] <> '"') do
-         i := i + 1;
-      end
-   else if FormatStr[i] = '''' then begin
-      i := i + 1;
-      while (i < length(FormatStr)) and (FormatStr[i] <> '''') do
-         i := i + 1;
-      end
-   else if (copy(FormatStr, i, 3) = 'a/p') then begin
-      FormatStr[i] := '"';
-      FormatStr[i + 1] := AP[h div 12];
-      FormatStr[i + 2] := '"';
-      Clock12 := True;
-      i := i + 2;
-      end
-   else if (copy(FormatStr, i, 5) = 'am/pm') then begin
-      Delete(FormatStr, i, 5);
-      if h < 12 then insert('"' + 'am' + '"', FormatStr, i)
-      else insert('"' + 'pm' + '"', FormatStr, i);
-      Clock12 := True;
-      i := i + 3;
-      end
-   else if (copy(FormatStr, i, 4) = 'ampm') then begin
-      Delete(FormatStr, i, 4);
-      current := TimeAMPMStrings[h div 12]^;
-      Insert('"' + current + '"', FormatStr, i);
-      Clock12 := True;
-      i := i + length(current) + 1;
-      end
-   else if copy(FormatStr, i, 2) = 'tt' then begin
-      Delete(FormatStr, i, 2);
-      Insert(LongTimeFormat, FormatStr, i);
-      i := i - 1;
-      end
-   else if FormatStr[i] = 't' then begin
-      Delete(FormatStr, i, 1);
-      Insert(ShortTimeFormat, FormatStr, i);
-      i := i - 1;
-      end
-   else if FormatStr[i] = 'c' then begin
-      Delete(FormatStr, i, 1);
-      Insert(ShortDateFormat + ' ' + ShortTimeFormat, FormatStr, i);
-      i := i - 1;
-      end
-   else if copy(FormatStr, i, 5) = 'ddddd' then begin
-      Delete(FormatStr, i, 5);
-      Insert(ShortDateFormat, FormatStr, i);
-      i := i - 1;
-      end
-   else if copy(FormatStr, i, 6) = 'dddddd' then begin
-      Delete(FormatStr, i, 6);
-      Insert(LongDateFormat, FormatStr, i);
-      i := i - 1;
+   ResultLen: integer;
+   ResultBuffer: array[0..255] of char;
+   ResultCurrent: pchar;
+
+   procedure StoreStr(Str: pchar; Len: integer);
+   begin
+   if ResultLen + Len < SizeOf(ResultBuffer) then begin
+      StrMove(ResultCurrent, Str, Len);
+      ResultCurrent := ResultCurrent + Len;
+      ResultLen := ResultLen + Len;
+      end ;
+   end ;
+
+   procedure StoreString(const Str: string);
+   var Len: integer;
+   begin
+   Len := Length(Str);
+   if ResultLen + Len < SizeOf(ResultBuffer) then begin
+      StrMove(ResultCurrent, pchar(@Str[1]), Len);
+      ResultCurrent := ResultCurrent + Len;
+      ResultLen := ResultLen + Len;
       end ;
    end ;
-current := '';
-i := 1;
-e := 0;
-while not(i > length(FormatStr)) do begin
-   while not(FormatStr[i] in [' ','"','/',':','''']) and not(i > length(FormatStr)) do begin
-      current := current + FormatStr[i];
-      inc(i);
+
+   procedure StoreInt(Value, Digits: integer);
+   var S: string; Len: integer;
+   begin
+   S := IntToStr(Value);
+   Len := Length(S);
+   if Len < Digits then begin
+      S := copy('0000', 1, Digits - Len) + S;
+      Len := Digits;
       end ;
-   if (current <> '') then begin
-      if (mTime <> 0) then begin
-         if (current = 'h') then begin
-            if clock12 then result := result + IntToStr(h mod 12)
-				else result := result + IntToStr(h);
-            end
-         else if (current = 'hh') then begin
-            if clock12 then result := result + RightStr('0' + IntToStr(h mod 12), 2)
-            else result := result + RightStr('0' + IntToStr(h), 2);
-            end
-         else if (current = 'n') then result := result + IntToStr(n)
-         else if (current = 'nn') then result := result + RightStr('0' + IntToStr(n), 2)
-         else if (current = 's') then result := result + IntToStr(s)
-         else if (current = 'ss') then result := result + RightStr('0' + IntToStr(s), 2);
-         end ;
-      if (mDate <> 0) then begin
-         if (current = 'd') then result := result + IntToStr(d)
-         else if (current = 'dd') then result := result + RightStr('0' + IntToStr(d), 2)
-         else if (current = 'ddd') then result := result + ShortDayNames[DayOfWeek(DateTime)]
-         else if (current = 'dddd') then result := result + LongDayNames[DayOfWeek(DateTime)]
-         else if (current = 'm') then result := result + IntToStr(m)
-         else if (current = 'mm') then result := result + RightStr('0' + IntToStr(m), 2)
-         else if (current = 'mmm') then result := result + ShortMonthNames[m]
-         else if (current = 'mmmm') then result := result + LongMonthNames[m]
-         else if (current = 'y') then result := result + IntToStr(y)
-         else if (current = 'yy') then result := result + RightStr(IntToStr(y), 2)
-         else if (current = 'yyyy') or (current = 'yyy') then result := result + IntToStr(y);
+   StoreStr(pchar(@S[1]), Len);
+   end ;
+
+var
+   Year, Month, Day, DayOfWeek, Hour, Minute, Second, MilliSecond: word;
+
+   procedure StoreFormat(const FormatStr: string);
+   var
+      Token: char;
+      FormatCurrent: pchar;
+      FormatEnd: pchar;
+      Count: integer;
+      Clock12: boolean;
+      P: pchar;
+
+   begin
+   FormatCurrent := @FormatStr[1];
+   FormatEnd := FormatCurrent + Length(FormatStr);
+   Clock12 := false;
+   P := FormatCurrent;
+   while P < FormatEnd do begin
+      Token := UpCase(P^);
+      if Token in ['"', ''''] then begin
+         P := P + 1;
+         while (P < FormatEnd) and (P^ <> Token) do
+            P := P + 1;
+         end
+      else if Token = 'A' then begin
+         if (StrLIComp(P, 'A/P', 3) = 0) or
+            (StrLIComp(P, 'AMPM', 4) = 0) or
+            (StrLIComp(P, 'AM/PM', 5) = 0) then begin
+            Clock12 := true;
+            break;
+            end ;
          end ;
-      current := '';
+      P := P + 1;
       end ;
-   if FormatStr[i] = ' ' then result := result + ' '
-   else if (FormatStr[i] = '/') and (mDate <> 0) then result := result + DateSeparator
-   else if (FormatStr[i] = ':') and (mTime <> 0) then result := result + TimeSeparator
-   else if (FormatStr[i] in ['"', '''']) then begin
-      ch := FormatStr[i];
-      inc(i);
-      while (i <= length(FormatStr)) and (FormatStr[i] <> ch) do begin
-         result := result + FormatStr[i];
-         inc(i);
+   while FormatCurrent < FormatEnd do begin
+      Token := UpCase(FormatCurrent^);
+      Count := 1;
+      P := FormatCurrent + 1;
+         case Token of
+            '''', '"': begin
+               while (P < FormatEnd) and (p^ <> Token) do
+                  P := P + 1;
+               P := P + 1;
+               Count := P - FormatCurrent;
+               StoreStr(FormatCurrent + 1, Count - 2);
+               end ;
+            'A': begin
+               if StrLIComp(FormatCurrent, 'AMPM', 4) = 0 then begin
+                  Count := 4;
+                  if Hour < 12 then StoreString(TimeAMString)
+                  else StoreString(TimePMString);
+                  end
+               else if StrLIComp(FormatCurrent, 'AM/PM', 5) = 0 then begin
+                  Count := 5;
+                  if Hour < 12 then StoreStr('am', 2)
+                  else StoreStr('pm', 2);
+                  end
+               else if StrLIComp(FormatCurrent, 'A/P', 3) = 0 then begin
+                  Count := 3;
+                  if Hour < 12 then StoreStr('a', 1)
+                  else StoreStr('p', 1);
+                  end
+               else Raise Exception.Create('Illegal character in format string');
+               end ;
+            '/': StoreStr(@DateSeparator, 1);
+            ':': StoreStr(@TimeSeparator, 1);
+            ' ', 'C', 'D', 'H', 'M', 'N', 'S', 'T', 'Y': begin
+               while (P < FormatEnd) and (UpCase(P^) = Token) do
+                  P := P + 1;
+               Count := P - FormatCurrent;
+                  case Token of
+                     ' ': StoreStr(FormatCurrent, Count);
+                     'Y': begin
+                           case Count of
+                              1: StoreInt(Year, 0);
+                              2: StoreInt(Year mod 100, 2);
+                              4: StoreInt(Year, 4);
+                           end ;
+                        end ;
+                     'M': begin
+                           case Count of
+                              1: StoreInt(Month, 0);
+                              2: StoreInt(Month, 2);
+                              3: StoreString(ShortMonthNames[Month]);
+                              4: StoreString(LongMonthNames[Month]);
+                           end ;
+                        end ;
+                     'D': begin
+                           case Count of
+                              1: StoreInt(Day, 0);
+                              2: StoreInt(Day, 2);
+                              3: StoreString(ShortDayNames[DayOfWeek]);
+                              4: StoreString(LongDayNames[DayOfWeek]);
+                              5: StoreFormat(ShortDateFormat);
+                              6: StoreFormat(LongDateFormat);
+                           end ;
+                        end ;
+                     'H': begin
+                        if Clock12 then begin
+                           if Count = 1 then StoreInt(Hour mod 12, 0)
+                           else StoreInt(Hour mod 12, 2);
+                           end
+                        else begin
+                           if Count = 1 then StoreInt(Hour, 0)
+                           else StoreInt(Hour, 2);
+                           end ;
+                        end ;
+                     'N': begin
+                        if Count = 1 then StoreInt(Minute, 0)
+                        else StoreInt(Minute, 2);
+                        end ;
+                     'S': begin
+                        if Count = 1 then StoreInt(Second, 0)
+                        else StoreInt(Second, 2);
+                        end ;
+                     'T': begin
+                        if Count = 1 then StoreFormat(ShortTimeFormat)
+                        else StoreFormat(LongTimeFormat);
+                        end ;
+                     'C': StoreFormat(ShortDateFormat + ' ' + ShortTimeFormat);
+                  end ;
+               end ;
+            else Raise Exception.Create('Illegal character in format string');
          end ;
+      FormatCurrent := FormatCurrent + Count;
       end ;
-   inc(i);
    end ;
+
+begin
+  DecodeDate(DateTime, Year, Month, Day);
+  DecodeTime(DateTime, Hour, Minute, Second, MilliSecond);
+  DayOfWeek := SysUtils.DayOfWeek(DateTime);
+  ResultLen := 0;
+  ResultCurrent := @ResultBuffer;
+  StoreFormat(FormatStr);
+  ResultBuffer[ResultLen] := #0;
+  result := StrPas(@ResultBuffer);
 end ;
 
 {   DateTimeToString formats DateTime to the given format in FormatStr   }
 
 procedure DateTimeToString(var Result: string; const FormatStr: string; const DateTime: TDateTime);
 begin
-Result := FormatDateTime(FormatStr, DateTime);
+  Result := FormatDateTime(FormatStr, DateTime);
 end ;
 
 
@@ -577,7 +621,10 @@ end;
 
 {
   $Log$
-  Revision 1.4  1998-10-11 13:40:52  michael
+  Revision 1.5  1998-10-15 09:39:12  michael
+  Changes from Gretjan Schouten
+
+  Revision 1.4  1998/10/11 13:40:52  michael
   + Added Conversion TDateTime <-> file date and time
 
   Revision 1.3  1998/09/16 08:28:36  michael