atari: most of the DOS unit is now implemented, but largely untested

git-svn-id: trunk@35254 -

rtl/atari/dos.pp

@@ -21,7 +21,8 @@ interface
 type
   SearchRec = record
     { Replacement for Fill }
-    Fill: Array[1..21] of Byte; {future use}
+    IFD: Pointer;
+    Fill: Array[1..17] of Byte; {future use}
     {End of replacement for fill}
     Attr : BYTE;        {attribute of found file}
     Time : LongInt;     {last modify date of found file}
@@ -38,52 +39,237 @@ implementation
 
 {$i dos.inc}
 
+{$i gemdos.inc}
+
+procedure Error2DosError(errno: longint);
+begin
+  case errno of
+    EFILNF: DosError:=2;   // File not found
+    EPTHNF: DosError:=3;   // Directory (folder/path) not found
+    EACCDN: DosError:=5;   // Access denied
+    EIHNDL: DosError:=6;   // Invalid file handle
+    ENSMEM: DosError:=8;   // Insufficient memory
+    ENMFIL: DosError:=18;  // No more files can be opened
+  else
+    DosError:=errno;
+  end;
+end;
+
 
 function DosVersion: Word;
 begin
   DosVersion:=0;
 end;
 
-procedure GetDate(Var Year, Month, MDay, WDay: Word);
+
+function WeekDay (y,m,d:longint):longint;
+{
+  Calculates th day of the week. returns -1 on error
+}
+var
+  u,v : longint;
 begin
+  if (m<1) or (m>12) or (y<1600) or (y>4000) or
+     (d<1) or (d>30+((m+ord(m>7)) and 1)-ord(m=2)) or
+     ((m*d=58) and (((y mod 4>0) or (y mod 100=0)) and (y mod 400>0))) then
+   WeekDay:=-1
+  else
+   begin
+     u:=m;
+     v:=y;
+     if m<3 then
+      begin
+        inc(u,12);
+        dec(v);
+      end;
+     WeekDay:=(d+2*u+((3*(u+1)) div 5)+v+(v div 4)-(v div 100)+(v div 400)+1) mod 7;
+   end;
+end;
+
+
+procedure GetDate(Var Year, Month, MDay, WDay: Word);
+var
+  TOSDate: LongInt;
+  D: DateTime;
+begin
+  TOSDate:=gemdos_tgetdate shl 16;
+
+  { the time values will be invalid here,
+    but it doesn't matter, we want the date }
+  UnpackTime(TOSDate,D);
+
+  Year:=D.Year;
+  Month:=D.Month;
+  MDay:=D.Day;
+  WDay:=WeekDay(Year,Month,MDay);
 end;
 
 procedure SetDate(Year, Month, Day: Word);
+var
+  D: DateTime;
+  TOSDate: LongInt;
 begin
+  D.Year:=Year;
+  D.Month:=Month;
+  D.Day:=Day;
+  PackTime(D,TOSDate);
+  gemdos_tsetdate(hi(TOSDate));
 end;
 
 procedure GetTime(Var Hour, Minute, Second, Sec100: Word);
+var
+  TOSTime: LongInt;
+  T: DateTime;
 begin
+  TOSTime:=gemdos_tgettime;
+
+  { the date values will be invalid here,
+    but it doesn't matter, we want the time }
+  UnpackTime(TOSTime,T);
+
+  Hour:=T.Hour;
+  Minute:=T.Min;
+  Second:=T.Sec;
+  Sec100:=0;
 end;
 
 procedure SetTime(Hour, Minute, Second, Sec100: Word);
+var
+  T: DateTime;
+  TOSTime: LongInt;
 begin
+  T.Hour:=Hour;
+  T.Min:=Minute;
+  T.Sec:=Second;
+  PackTime(T,TOSTime);
+  gemdos_tsettime(lo(TOSTime));
 end;
 
 procedure Exec(const Path: PathStr; const ComLine: ComStr);
+var
+  dosResult: LongInt;
+  tmpPath: String;
 begin
-end;
+  tmpPath:=Path+#0;
+  DoDirSeparators(tmpPath);
 
-function DiskFree(Drive: Byte): Int64;
+  { the zero offset for cmdline is actually correct here. pexec() expects
-begin
+    pascal formatted string for cmdline, so length in first byte }
-  DiskFree:=-1;
+  dosResult:=gemdos_pexec(0,PChar(@tmpPath[1]),@ComLine[0],nil);
+  if dosResult < 0 then
+    Error2DosError(dosResult);
 end;
 
 function DiskSize(Drive: Byte): Int64;
+var
+  dosResult: longint;
+  di: TDISKINFO;
 begin
-  DiskSize:=-1;
+  DiskSize := -1;
+
+  dosResult:=gemdos_dfree(@di,drive);
+  if dosResult < 0 then
+    exit;
+
+  DiskSize:=di.b_total * di.b_secsiz * di.b_clsiz;
 end;
 
-procedure FindFirst(const Path: PathStr; Attr: Word; Var f: SearchRec);
+function DiskFree(Drive: Byte): Int64;
+var
+  dosResult: longint;
+  di: TDISKINFO;
 begin
+  DiskFree := -1;
+
+  dosResult:=gemdos_dfree(@di,drive);
+  if dosResult < 0 then
+    exit;
+
+  DiskFree:=di.b_free * di.b_secsiz * di.b_clsiz;
+end;
+
+
+type
+  PInternalFindData = ^TInternalFindData;
+  TInternalFindData = record
+    dta_original: pointer;
+    dta_search: TDTA;
+  end;
+
+procedure FindFirst(const Path: PathStr; Attr: Word; Var f: SearchRec);
+var
+  p: PathStr;
+  r: RawByteString;
+  dosResult: LongInt;
+  IFD: PInternalFindData;
+begin
+  p:=Path;
+  DoDirSeparators(p);
+  r:=p;
+
+  new(IFD);
+  IFD^.dta_original:=gemdos_getdta;
+  gemdos_setdta(@IFD^.dta_search);
+
+  f.IFD:=IFD;
+  dosResult:=gemdos_fsfirst(pchar(r), Attr);
+  if dosResult < 0 then
+    begin
+      Error2DosError(dosResult);
+      exit;
+    end;
+
+  DosError:=0;
+  with IFD^.dta_search do
+    begin
+      f.name:=d_fname;
+      f.time:=(d_date shl 16) + d_time;
+      f.size:=d_length;
+      f.attr:=d_attrib;
+    end;
 end;
 
 procedure FindNext(Var f: SearchRec);
+var
+  IFD: PInternalFindData;
+  dosResult: LongInt;
 begin
+  IFD:=f.IFD;
+  if not assigned(IFD) then
+    begin
+      DosError:=6;
+      exit;
+    end;
+
+  dosResult:=gemdos_fsnext;
+  if dosResult < 0 then
+    begin
+      Error2DosError(dosResult);
+      exit;
+    end;
+
+  DosError:=0;
+  with IFD^.dta_search do
+    begin
+      f.name:=d_fname;
+      f.time:=(d_date shl 16) + d_time;
+      f.size:=d_length;
+      f.attr:=d_attrib;
+    end;
 end;
 
 procedure FindClose(Var f: SearchRec);
+var
+  IFD: PInternalFindData;
 begin
+  IFD:=f.IFD;
+  if not assigned(IFD) then
+    exit;
+
+  gemdos_setdta(IFD^.dta_original);
+
+  dispose(IFD);
+  f.IFD:=nil;
 end;
 
 function FSearch(path: PathStr; dirlist: String) : PathStr;
@@ -92,19 +278,64 @@ begin
 end;
 
 procedure GetFAttr(var f; var Attr : word);
+var
+  dosResult: LongInt;
+  path: PChar;
+{$ifndef FPC_ANSI_TEXTFILEREC}
+  r: rawbytestring;
+{$endif not FPC_ANSI_TEXTFILEREC}
 begin
+{$ifdef FPC_ANSI_TEXTFILEREC}
+  path:=@filerec(f).Name;
+{$else}
+  r:=ToSingleByteFileSystemEncodedFileName(filerec(f).Name);
+  path:=pchar(r);
+{$endif}
+
+  Attr:=0;
+  dosResult:=gemdos_fattrib(path,0,0);
+  if dosResult < 0 then
+    Error2DosError(dosResult)
+  else
+    Attr:=word(dosResult);
 end;
 
 procedure GetFTime(var f; var Time : longint);
+var
+  td: TDOSTIME;
 begin
+  gemdos_fdatime(@td,TextRec(f).Handle,0);
+  Time:=(td.date << 16) + td.time;
 end;
 
 procedure SetFAttr(var f; attr : word);
+var
+  dosResult: LongInt;
+  path: PChar;
+{$ifndef FPC_ANSI_TEXTFILEREC}
+  r: rawbytestring;
+{$endif not FPC_ANSI_TEXTFILEREC}
 begin
+{$ifdef FPC_ANSI_TEXTFILEREC}
+  path:=@filerec(f).Name;
+{$else}
+  r:=ToSingleByteFileSystemEncodedFileName(filerec(f).Name);
+  path:=pchar(r);
+{$endif}
+
+  dosResult:=gemdos_fattrib(pchar(@FileRec(f).name),1,Attr);
+  if dosResult < 0 then
+    Error2DosError(dosResult)
 end;
 
 procedure SetFTime(var f; time : longint);
+var
+  td: TDOSTIME;
 begin
+  td.date:=Hi(Time);
+  td.time:=Lo(Time);
+
+  gemdos_fdatime(@td,TextRec(f).Handle,1);
 end;
 
 function EnvCount: Longint;

rtl/atari/gemdos.inc

@@ -129,8 +129,9 @@ function gemdos_dgetdrv: smallint; syscall 1 25;
 procedure gemdos_setdta(buf: PDTA); syscall 1 26;
 
 function gemdos_tgetdate: longint; syscall 1 42;
-
+function gemdos_tsetdate(date: word): smallint; syscall 1 43;
 function gemdos_tgettime: longint; syscall 1 44;
+function gemdos_tsettime(time: word): smallint; syscall 1 45;
 
 function gemdos_getdta: PDTA; syscall 1 47;
 function gemdos_sversion: smallint; syscall 1 48;