diff --git a/rtl/atari/dos.pp b/rtl/atari/dos.pp index 2b6f3a2d43..af3e0a3150 100644 --- a/rtl/atari/dos.pp +++ b/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; -begin - DiskFree:=-1; + { the zero offset for cmdline is actually correct here. pexec() expects + pascal formatted string for cmdline, so length in first byte } + 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; diff --git a/rtl/atari/gemdos.inc b/rtl/atari/gemdos.inc index cd975d82e6..46d764d3cd 100644 --- a/rtl/atari/gemdos.inc +++ b/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;