mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-04-24 04:19:26 +02:00
atari: most of the DOS unit is now implemented, but largely untested
git-svn-id: trunk@35254 -
This commit is contained in:
parent
58f85ed4e4
commit
a8a9a5f5de
rtl/atari
247
rtl/atari/dos.pp
247
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;
|
||||
|
@ -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;
|
||||
|
Loading…
Reference in New Issue
Block a user