paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-08-28 21:00:28 +02:00
Code Issues Packages Projects Releases Wiki Activity

* GetMsCount added, platform independent routines moved to single include file

Browse Source
This commit is contained in:
Tomas Hajny 2004-12-05 16:44:43 +00:00
parent 08da4e9278
commit e1252e7302
12 changed files with 276 additions and 1795 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

170
rtl/amiga/dos.pp
View File

@ -33,9 +33,6 @@ Interface
{$I os.inc} {$I os.inc}
Const
FileNameLen = 255;
type type
SearchRec = Packed Record SearchRec = Packed Record
{ watch out this is correctly aligned for all processors } { watch out this is correctly aligned for all processors }
@ -50,17 +47,19 @@ type
Name : String[255]; {name of found file} Name : String[255]; {name of found file}
End; End;
registers = packed record
case i : integer of
0 : (ax,f1,bx,f2,cx,f3,dx,f4,bp,f5,si,f51,di,f6,ds,f7,es,f8,flags,fs,gs : word);
1 : (al,ah,f9,f10,bl,bh,f11,f12,cl,ch,f13,f14,dl,dh : byte);
2 : (eax, ebx, ecx, edx, ebp, esi, edi : longint);
end;
{$i dosh.inc} {$i dosh.inc}
implementation implementation
{$DEFINE HAS_GETCBREAK}
{$DEFINE HAS_SETCBREAK}
{$DEFINE FPC_FEXPAND_VOLUMES} (* Full paths begin with drive specification *)
{$DEFINE FPC_FEXPAND_DRIVESEP_IS_ROOT}
{$DEFINE FPC_FEXPAND_NO_DEFAULT_PATHS}
{$I dos.inc}
const const
DaysPerMonth : Array[1..12] of ShortInt = DaysPerMonth : Array[1..12] of ShortInt =
(031,028,031,030,031,030,031,031,030,031,030,031); (031,028,031,030,031,030,031,031,030,031,030,031);
@ -611,38 +610,6 @@ begin
end; end;
Procedure AmigaToDt(SecsPast: LongInt; Var Dt: DateTime);
var
cd : pClockData;
Begin
New(cd);
Amiga2Date(SecsPast,cd);
Dt.sec := cd^.sec;
Dt.min := cd^.min;
Dt.hour := cd^.hour;
Dt.day := cd^.mday;
Dt.month := cd^.month;
Dt.year := cd^.year;
Dispose(cd);
End;
Function DtToAmiga(DT: DateTime): LongInt;
var
cd : pClockData;
temp : Longint;
Begin
New(cd);
cd^.sec := Dt.sec;
cd^.min := Dt.min;
cd^.hour := Dt.hour;
cd^.mday := Dt.day;
cd^.month := Dt.month;
cd^.year := Dt.year;
temp := Date2Amiga(cd);
Dispose(cd);
DtToAmiga := temp;
end;
Function SetProtection(const name: string; mask:longint): longint; Function SetProtection(const name: string; mask:longint): longint;
var var
buffer : array[0..255] of char; buffer : array[0..255] of char;
@ -664,7 +631,8 @@ Function SetProtection(const name: string; mask:longint): longint;
Function IsLeapYear(Source : Word) : Boolean; Function IsLeapYear(Source : Word) : Boolean;
Begin Begin
If (Source Mod 4 = 0) Then If (Source mod 400 = 0) or ((Source mod 4 = 0) and (Source mod 100 <> 0))
Then
IsLeapYear := True IsLeapYear := True
Else Else
IsLeapYear := False; IsLeapYear := False;
@ -750,41 +718,6 @@ End;
{******************************************************************************
--- Dos Interrupt ---
******************************************************************************}
Procedure Intr (intno: byte; var regs: registers);
Begin
{ Does not apply to Linux - not implemented }
End;
Procedure SwapVectors;
Begin
{ Does not apply to Linux - Do Nothing }
End;
Procedure msdos(var regs : registers);
Begin
{ ! Not implemented in Linux ! }
End;
Procedure getintvec(intno : byte;var vector : pointer);
Begin
{ ! Not implemented in Linux ! }
End;
Procedure setintvec(intno : byte;vector : pointer);
Begin
{ ! Not implemented in Linux ! }
End;
{****************************************************************************** {******************************************************************************
--- Info / Date / Time --- --- Info / Date / Time ---
******************************************************************************} ******************************************************************************}
@ -839,31 +772,11 @@ Procedure SetTime(Hour, Minute, Second, Sec100: Word);
{ !! } { !! }
End; End;
Procedure unpacktime(p : longint;var t : datetime);
Begin
AmigaToDt(p,t);
End;
Procedure packtime(var t : datetime;var p : longint);
Begin
p := DtToAmiga(t);
end;
{****************************************************************************** {******************************************************************************
--- Exec --- --- Exec ---
******************************************************************************} ******************************************************************************}
{$ifdef HASTHREADVAR}
threadvar
{$else HASTHREADVAR}
var
{$endif HASTHREADVAR}
LastDosExitCode: word;
Procedure Exec (Const Path: PathStr; Const ComLine: ComStr); Procedure Exec (Const Path: PathStr; Const ComLine: ComStr);
var var
p : string; p : string;
@ -903,12 +816,6 @@ Procedure Exec (Const Path: PathStr; Const ComLine: ComStr);
End; End;
Function DosExitCode: Word;
Begin
DosExitCode:=LastdosExitCode;
End;
Procedure GetCBreak(Var BreakValue: Boolean); Procedure GetCBreak(Var BreakValue: Boolean);
Begin Begin
breakvalue := system.BreakOn; breakvalue := system.BreakOn;
@ -921,16 +828,6 @@ Function DosExitCode: Word;
End; End;
Procedure GetVerify(Var Verify: Boolean);
Begin
verify:=true;
End;
Procedure SetVerify(Verify: Boolean);
Begin
End;
{****************************************************************************** {******************************************************************************
--- Disk --- --- Disk ---
******************************************************************************} ******************************************************************************}
@ -1188,35 +1085,7 @@ End;
--- File --- --- File ---
******************************************************************************} ******************************************************************************}
Procedure FSplit(path: pathstr; var dir: dirstr; var name: namestr; var ext: extstr); (*
var
I: Word;
begin
{ allow backslash as slash }
for i:=1 to length(path) do
if path[i]='\' then path[i]:='/';
I := Length(Path);
while (I > 0) and not ((Path[I] = '/') or (Path[I] = ':'))
do Dec(I);
if Path[I] = '/' then
dir := Copy(Path, 0, I)
else dir := Copy(Path,0,I);
if Length(Path) > Length(dir) then
name := Copy(Path, I + 1, Length(Path)-I)
else
name := '';
{ Remove extension }
if pos('.',name) <> 0 then
delete(name,pos('.',name),length(name));
I := Pos('.',Path);
if I > 0 then
ext := Copy(Path,I,Length(Path)-(I-1))
else ext := '';
end;
Function FExpand(Path: PathStr): PathStr; Function FExpand(Path: PathStr): PathStr;
var var
FLock : BPTR; FLock : BPTR;
@ -1266,6 +1135,7 @@ begin
end; end;
end else FExpand := ''; end else FExpand := '';
end; end;
*)
Function fsearch(path : pathstr;dirlist : string) : pathstr; Function fsearch(path : pathstr;dirlist : string) : pathstr;
@ -1533,15 +1403,6 @@ begin
end; end;
{******************************************************************************
--- Not Supported ---
******************************************************************************}
Procedure keep(exitcode : word);
Begin
{ ! Not implemented in Linux ! }
End;
procedure AddDevice(str : String); procedure AddDevice(str : String);
begin begin
inc(numberofdevices); inc(numberofdevices);
@ -1612,7 +1473,10 @@ End.
{ {
$Log$ $Log$
Revision 1.8 2004-02-17 17:37:25 daniel Revision 1.9 2004-12-05 16:44:43 hajny
* GetMsCount added, platform independent routines moved to single include file
Revision 1.8 2004/02/17 17:37:25 daniel
* Enable threadvars again * Enable threadvars again
Revision 1.7 2004/02/16 22:16:55 hajny Revision 1.7 2004/02/16 22:16:55 hajny

165
rtl/beos/dos.pp
View File

@ -20,9 +20,6 @@ Interface
{$goto on} {$goto on}
Const
FileNameLen=255;
Type Type
SearchRec = packed Record SearchRec = packed Record
{Fill : array[1..21] of byte; Fill replaced with below} {Fill : array[1..21] of byte; Fill replaced with below}
@ -39,13 +36,6 @@ Type
SearchDir : String[FileNameLen]; { path we are searching in } SearchDir : String[FileNameLen]; { path we are searching in }
End; End;
Registers = packed record
case i : integer of
0 : (ax,f1,bx,f2,cx,f3,dx,f4,bp,f5,si,f51,di,f6,ds,f7,es,f8,flags,fs,gs : word);
1 : (al,ah,f9,f10,bl,bh,f11,f12,cl,ch,f13,f14,dl,dh : byte);
2 : (eax, ebx, ecx, edx, ebp, esi, edi : longint);
End;
{$i dosh.inc} {$i dosh.inc}
Procedure AddDisk(const path:string); Procedure AddDisk(const path:string);
@ -53,8 +43,10 @@ Procedure AddDisk(const path:string);
Implementation Implementation
Uses Uses
Strings,posix; strings,posix;
(* Potentially needed FPC_FEXPAND_* defines should be defined here. *)
{$I dos.inc}
{ Used by AddDisk(), DiskFree() and DiskSize() } { Used by AddDisk(), DiskFree() and DiskSize() }
const const
@ -111,7 +103,7 @@ begin
end; end;
{$i dos.inc} { include OS specific stuff } {$i dos_beos.inc} { include OS specific stuff }
@ -251,25 +243,6 @@ Begin
End; End;
Procedure packtime(var t : datetime;var p : longint);
Begin
p:=(t.sec shr 1)+(t.min shl 5)+(t.hour shl 11)+(t.day shl 16)+(t.month shl 21)+((t.year-1980) shl 25);
End;
Procedure unpacktime(p : longint;var t : datetime);
Begin
t.sec:=(p and 31) shl 1;
t.min:=(p shr 5) and 63;
t.hour:=(p shr 11) and 31;
t.day:=(p shr 16) and 31;
t.month:=(p shr 21) and 15;
t.year:=(p shr 25)+1980;
End;
Procedure UnixDateToDt(SecsPast: LongInt; Var Dt: DateTime); Procedure UnixDateToDt(SecsPast: LongInt; Var Dt: DateTime);
Begin Begin
EpochToLocal(SecsPast,dt.Year,dt.Month,dt.Day,dt.Hour,dt.Min,dt.Sec); EpochToLocal(SecsPast,dt.Year,dt.Month,dt.Day,dt.Hour,dt.Min,dt.Sec);
@ -281,14 +254,6 @@ End;
--- Exec --- --- Exec ---
******************************************************************************} ******************************************************************************}
{$ifdef HASTHREADVAR}
threadvar
{$else HASTHREADVAR}
var
{$endif HASTHREADVAR}
LastDosExitCode: word;
Function InternalWaitProcess(Pid:pid_t):Longint; { like WaitPid(PID,@result,0) Handling of Signal interrupts (errno=EINTR), returning the Exitcode of Process (>=0) or -Status if terminated} Function InternalWaitProcess(Pid:pid_t):Longint; { like WaitPid(PID,@result,0) Handling of Signal interrupts (errno=EINTR), returning the Exitcode of Process (>=0) or -Status if terminated}
var r,s : cint; var r,s : cint;
begin begin
@ -376,11 +341,6 @@ Begin
if (LastDosExitCode>=0) and (LastDosExitCode<>127) then DosError:=0 else if (LastDosExitCode>=0) and (LastDosExitCode<>127) then DosError:=0 else
DosError:=8; // perhaps one time give an better error DosError:=8; // perhaps one time give an better error
End; End;
Function DosExitCode: Word;
Begin
DosExitCode:=LastDosExitCode;
End;
{$ENDIF} {$ENDIF}
@ -650,44 +610,6 @@ End;
--- File --- --- File ---
******************************************************************************} ******************************************************************************}
Procedure FSplit(const Path:PathStr;Var Dir:DirStr;Var Name:NameStr;Var Ext:ExtStr);
Var
DotPos,SlashPos,i : longint;
Begin
SlashPos:=0;
DotPos:=256;
i:=Length(Path);
While (i>0) and (SlashPos=0) Do
Begin
If (DotPos=256) and (Path[i]='.') Then
begin
DotPos:=i;
end;
If (Path[i]='/') Then
SlashPos:=i;
Dec(i);
End;
Ext:=Copy(Path,DotPos,255);
Dir:=Copy(Path,1,SlashPos);
Name:=Copy(Path,SlashPos + 1,DotPos - SlashPos - 1);
End;
{
function FExpand (const Path: PathStr): PathStr;
- declared in fexpand.inc
}
(*
{$DEFINE FPC_FEXPAND_TILDE} { Tilde is expanded to home }
*)
const
LFNSupport = true;
FileNameCaseSensitive = true;
{$I fexpand.inc}
Function FSearch(const path:pathstr;dirlist:string):pathstr; Function FSearch(const path:pathstr;dirlist:string):pathstr;
{ {
@ -866,52 +788,6 @@ end;
{******************************************************************************
--- Do Nothing Procedures/Functions ---
******************************************************************************}
Procedure Intr (intno: byte; var regs: registers);
Begin
{! No POSIX equivalent !}
End;
Procedure msdos(var regs : registers);
Begin
{! No POSIX equivalent !}
End;
Procedure getintvec(intno : byte;var vector : pointer);
Begin
{! No POSIX equivalent !}
End;
Procedure setintvec(intno : byte;vector : pointer);
Begin
{! No POSIX equivalent !}
End;
Procedure SwapVectors;
Begin
{! No POSIX equivalent !}
End;
Procedure keep(exitcode : word);
Begin
{! No POSIX equivalent !}
End;
Procedure setftime(var f; time : longint); Procedure setftime(var f; time : longint);
Begin Begin
{! No POSIX equivalent !} {! No POSIX equivalent !}
@ -926,34 +802,6 @@ End;
Procedure GetCBreak(Var BreakValue: Boolean);
Begin
{! No POSIX equivalent !}
breakvalue:=true
End;
Procedure SetCBreak(BreakValue: Boolean);
Begin
{! No POSIX equivalent !}
End;
Procedure GetVerify(Var Verify: Boolean);
Begin
{! No POSIX equivalent !}
Verify:=true;
End;
Procedure SetVerify(Verify: Boolean);
Begin
{! No POSIX equivalent !}
End;
{ Include timezone routines } { Include timezone routines }
{$i timezone.inc} {$i timezone.inc}
@ -969,7 +817,10 @@ finalization
end. end.
{ {
$Log$ $Log$
Revision 1.9 2004-02-17 17:37:26 daniel Revision 1.10 2004-12-05 16:44:43 hajny
* GetMsCount added, platform independent routines moved to single include file
Revision 1.9 2004/02/17 17:37:26 daniel
* Enable threadvars again * Enable threadvars again
Revision 1.8 2004/02/16 22:16:57 hajny Revision 1.8 2004/02/16 22:16:57 hajny

210
rtl/emx/dos.pas
View File

@ -30,16 +30,13 @@ interface
uses Strings, DosCalls; uses Strings, DosCalls;
Const
FileNameLen = 255;
Type Type
{Search record which is used by findfirst and findnext:} {Search record which is used by findfirst and findnext:}
searchrec=record searchrec=record
case boolean of case boolean of
false: (handle:longint; {Used in os_OS2 mode} false: (handle:THandle; {Used in os_OS2 mode}
FStat:PFileFindBuf3; FStat:PFileFindBuf3;
fill2:array[1..21-SizeOf(longint)-SizeOf(pointer)] of byte; fill2:array[1..21-SizeOf(THandle)-SizeOf(pointer)] of byte;
attr2:byte; attr2:byte;
time2:longint; time2:longint;
size2:longint; size2:longint;
@ -51,16 +48,6 @@ Type
name:string); {Filenames can be long in OS/2!} name:string); {Filenames can be long in OS/2!}
end; end;
{Data structure for the registers needed by msdos and intr:}
registers=packed record
case i:integer of
0:(ax,f1,bx,f2,cx,f3,dx,f4,bp,f5,si,f51,di,f6,ds,f7,es,
f8,flags,fs,gs:word);
1:(al,ah,f9,f10,bl,bh,f11,f12,cl,ch,f13,f14,dl,dh:byte);
2:(eax,ebx,ecx,edx,ebp,esi,edi:longint);
end;
{$i dosh.inc} {$i dosh.inc}
{Flags for the exec procedure: {Flags for the exec procedure:
@ -127,13 +114,24 @@ var
implementation implementation
{$DEFINE HAS_INTR}
{$DEFINE HAS_SETVERIFY}
{$DEFINE HAS_GETVERIFY}
{$DEFINE FPC_FEXPAND_UNC} (* UNC paths are supported *)
{$DEFINE FPC_FEXPAND_DRIVES} (* Full paths begin with drive specification *)
const
LFNSupport = true;
{$I dos.inc}
{$ifdef HASTHREADVAR} {$ifdef HASTHREADVAR}
threadvar threadvar
{$else HASTHREADVAR} {$else HASTHREADVAR}
var var
{$endif HASTHREADVAR} {$endif HASTHREADVAR}
LastDosExitCode: longint;
LastSR: SearchRec; LastSR: SearchRec;
var var
@ -218,6 +216,7 @@ begin
end; end;
end; end;
procedure GetFTime (var F; var Time: longint); assembler; procedure GetFTime (var F; var Time: longint); assembler;
asm asm
pushl %ebx pushl %ebx
@ -244,6 +243,7 @@ asm
popl %ebx popl %ebx
end {['eax', 'ecx', 'edx']}; end {['eax', 'ecx', 'edx']};
procedure SetFTime (var F; Time: longint); procedure SetFTime (var F; Time: longint);
var FStat: TFileStatus3; var FStat: TFileStatus3;
@ -281,16 +281,8 @@ begin
end ['eax', 'ecx', 'edx']; end ['eax', 'ecx', 'edx'];
end; end;
procedure msdos(var regs:registers);
{Not recommended for EMX. Only works in DOS mode, not in OS/2 mode.} procedure Intr (IntNo: byte; var Regs: Registers);
begin
if os_mode in [osDPMI,osDOS] then
intr($21,regs);
end;
procedure intr(intno:byte;var regs:registers);
{Not recommended for EMX. Only works in DOS mode, not in OS/2 mode.} {Not recommended for EMX. Only works in DOS mode, not in OS/2 mode.}
@ -497,13 +489,6 @@ begin
end; end;
function DosExitCode: word;
begin
DosExitCode := LastDosExitCode and $FFFF;
end;
function dosversion:word;assembler; function dosversion:word;assembler;
{Returns DOS version in DOS and OS/2 version in OS/2} {Returns DOS version in DOS and OS/2 version in OS/2}
@ -512,6 +497,7 @@ asm
call syscall call syscall
end ['eax']; end ['eax'];
procedure GetDate (var Year, Month, MDay, WDay: word); procedure GetDate (var Year, Month, MDay, WDay: word);
begin begin
@ -533,8 +519,8 @@ begin
end ['eax', 'ecx', 'edx']; end ['eax', 'ecx', 'edx'];
end; end;
{$asmmode intel}
{$asmmode intel}
procedure SetDate (Year, Month, Day: word); procedure SetDate (Year, Month, Day: word);
var DT: TDateTime; var DT: TDateTime;
begin begin
@ -555,9 +541,9 @@ begin
call syscall call syscall
end ['eax', 'ecx', 'edx']; end ['eax', 'ecx', 'edx'];
end; end;
{$asmmode att} {$asmmode att}
procedure GetTime (var Hour, Minute, Second, Sec100: word); procedure GetTime (var Hour, Minute, Second, Sec100: word);
{$IFDEF REGCALL} {$IFDEF REGCALL}
begin begin
@ -587,6 +573,7 @@ end;
end {['eax', 'ecx', 'edx']}; end {['eax', 'ecx', 'edx']};
{$ENDIF REGCALL} {$ENDIF REGCALL}
{$asmmode intel} {$asmmode intel}
procedure SetTime (Hour, Minute, Second, Sec100: word); procedure SetTime (Hour, Minute, Second, Sec100: word);
var DT: TDateTime; var DT: TDateTime;
@ -613,24 +600,6 @@ end;
{$asmmode att} {$asmmode att}
procedure getcbreak(var breakvalue:boolean);
begin
breakvalue := True;
end;
procedure setcbreak(breakvalue:boolean);
begin
{! Do not use in OS/2. Also not recommended in DOS. Use
signal handling instead.
asm
movb BreakValue,%dl
movw $0x3301,%ax
call syscall
end ['eax', 'edx'];
}
end;
procedure getverify(var verify:boolean); procedure getverify(var verify:boolean);
@ -830,7 +799,7 @@ begin
if os_mode = osOS2 then if os_mode = osOS2 then
begin begin
New (F.FStat); New (F.FStat);
F.Handle := longint ($FFFFFFFF); F.Handle := THandle ($FFFFFFFF);
Count := 1; Count := 1;
DosError := integer (DosFindFirst (Path, F.Handle, DosError := integer (DosFindFirst (Path, F.Handle,
Attr and FindResvdMask, F.FStat, SizeOf (F.FStat^), Attr and FindResvdMask, F.FStat, SizeOf (F.FStat^),
@ -877,25 +846,23 @@ begin
DosSearchRec2SearchRec (F); DosSearchRec2SearchRec (F);
end; end;
procedure FindClose (var F: SearchRec); procedure FindClose (var F: SearchRec);
begin begin
if os_mode = osOS2 then if os_mode = osOS2 then
begin begin
if F.Handle <> $FFFFFFFF then DosError := DosFindClose (F.Handle); if F.Handle <> THandle ($FFFFFFFF) then DosError := DosFindClose (F.Handle);
Dispose (F.FStat); Dispose (F.FStat);
end; end;
end; end;
procedure swapvectors;
{For TP compatibility, this exists.}
begin
end;
function envcount:longint;assembler; function envcount:longint;assembler;
asm asm
movl envc,%eax movl envc,%eax
end ['EAX']; end ['EAX'];
function envstr(index : longint) : string; function envstr(index : longint) : string;
var hp:Pchar; var hp:Pchar;
@ -910,6 +877,7 @@ begin
envstr:=strpas(hp); envstr:=strpas(hp);
end; end;
function GetEnvPChar (EnvVar: string): PChar; function GetEnvPChar (EnvVar: string): PChar;
(* The assembler version is more than three times as fast as Pascal. *) (* The assembler version is more than three times as fast as Pascal. *)
var var
@ -969,108 +937,12 @@ begin
end; end;
{$ASMMODE ATT} {$ASMMODE ATT}
function GetEnv (EnvVar: string): string; function GetEnv (EnvVar: string): string;
begin begin
GetEnv := StrPas (GetEnvPChar (EnvVar)); GetEnv := StrPas (GetEnvPChar (EnvVar));
end; end;
procedure fsplit(path:pathstr;var dir:dirstr;var name:namestr;
var ext:extstr);
var p1,i : longint;
dotpos : integer;
begin
{ allow slash as backslash }
for i:=1 to length(path) do
if path[i]='/' then path[i]:='\';
{Get drive name}
p1:=pos(':',path);
if p1>0 then
begin
dir:=path[1]+':';
delete(path,1,p1);
end
else
dir:='';
{ split the path and the name, there are no more path informtions }
{ if path contains no backslashes }
while true do
begin
p1:=pos('\',path);
if p1=0 then
break;
dir:=dir+copy(path,1,p1);
delete(path,1,p1);
end;
{ try to find out a extension }
Ext:='';
i:=Length(Path);
DotPos:=256;
While (i>0) Do
Begin
If (Path[i]='.') Then
begin
DotPos:=i;
break;
end;
Dec(i);
end;
Ext:=Copy(Path,DotPos,255);
Name:=Copy(Path,1,DotPos - 1);
end;
(*
function FExpand (const Path: PathStr): PathStr;
- declared in fexpand.inc
*)
{$DEFINE FPC_FEXPAND_UNC} (* UNC paths are supported *)
{$DEFINE FPC_FEXPAND_DRIVES} (* Full paths begin with drive specification *)
const
LFNSupport = true;
{$I fexpand.inc}
{$UNDEF FPC_FEXPAND_DRIVES}
{$UNDEF FPC_FEXPAND_UNC}
procedure PackTime (var T: DateTime; var P: longint);
var zs:longint;
begin
P := -1980;
P := P + T.Year and 127;
P := P shl 4;
P := P + T.Month;
P := P shl 5;
P := P + T.Day;
P := P shl 16;
zs:= T.hour;
zs:= zs shl 6;
zs:= zs + T.Min;
zs:= zs shl 5;
zs:= zs + T.Sec div 2;
P := P + (zs and $ffff);
end;
procedure unpacktime (P: longint; var T: DateTime);
begin
T.Sec := (P and 31) * 2;
P := P shr 5;
T.Min := P and 63;
P := P shr 6;
T.Hour := P and 31;
P := P shr 5;
T.Day := P and 31;
P := P shr 5;
T.Month := P and 15;
P := P shr 4;
T.Year := P + 1980;
end;
procedure getfattr(var f;var attr : word); procedure getfattr(var f;var attr : word);
{ Under EMX, this routine requires } { Under EMX, this routine requires }
@ -1102,6 +974,7 @@ begin
end ['eax', 'ecx', 'edx']; end ['eax', 'ecx', 'edx'];
end; end;
procedure setfattr(var f;attr : word); procedure setfattr(var f;attr : word);
{ Under EMX, this routine requires } { Under EMX, this routine requires }
{ the expanded path specification } { the expanded path specification }
@ -1195,28 +1068,6 @@ var
--- Not Supported --- --- Not Supported ---
******************************************************************************} ******************************************************************************}
procedure Keep (ExitCode: word);
begin
end;
procedure GetIntVec (IntNo: byte; var Vector: pointer);
begin
end;
procedure SetIntVec (IntNo: byte; Vector: pointer);
begin
end;
function GetShortName(var p : String) : boolean;
begin
GetShortName:=true;
end;
function GetLongName(var p : String) : boolean;
begin
GetLongName:=true;
end;
begin begin
@ -1229,7 +1080,10 @@ end.
{ {
$Log$ $Log$
Revision 1.15 2004-03-21 20:35:24 hajny Revision 1.16 2004-12-05 16:44:43 hajny
* GetMsCount added, platform independent routines moved to single include file
Revision 1.15 2004/03/21 20:35:24 hajny
* Exec cleanup * Exec cleanup
Revision 1.14 2004/03/08 22:31:00 hajny Revision 1.14 2004/03/08 22:31:00 hajny

150
rtl/go32v2/dos.pp
View File

@ -20,9 +20,6 @@ interface
Uses Uses
Go32; Go32;
Const
FileNameLen = 255;
Type Type
searchrec = packed record searchrec = packed record
fill : array[1..21] of byte; fill : array[1..21] of byte;
@ -33,6 +30,7 @@ Type
name : string[255]; { LFN Name, DJGPP uses only [12] but more can't hurt (PFV) } name : string[255]; { LFN Name, DJGPP uses only [12] but more can't hurt (PFV) }
end; end;
{$DEFINE HAS_REGISTERS}
Registers = Go32.Registers; Registers = Go32.Registers;
{$i dosh.inc} {$i dosh.inc}
@ -42,6 +40,21 @@ implementation
uses uses
strings; strings;
{$DEFINE HAS_GETMSCOUNT}
{$DEFINE HAS_INTR}
{$DEFINE HAS_SETCBREAK}
{$DEFINE HAS_GETCBREAK}
{$DEFINE HAS_SETVERIFY}
{$DEFINE HAS_GETVERIFY}
{$DEFINE HAS_SWAPVECTORS}
{$DEFINE HAS_GETSHORTNAME}
{$DEFINE HAS_GETLONGNAME}
{$DEFINE FPC_FEXPAND_UNC} (* UNC paths are supported *)
{$DEFINE FPC_FEXPAND_DRIVES} (* Full paths begin with drive specification *)
{$I dos.inc}
{****************************************************************************** {******************************************************************************
--- Dos Interrupt --- --- Dos Interrupt ---
******************************************************************************} ******************************************************************************}
@ -82,12 +95,6 @@ begin
end; end;
procedure msdos(var regs : registers);
begin
intr($21,regs);
end;
{****************************************************************************** {******************************************************************************
--- Info / Date / Time --- --- Info / Date / Time ---
******************************************************************************} ******************************************************************************}
@ -143,37 +150,16 @@ begin
end; end;
Procedure packtime(var t : datetime;var p : longint); function GetMsCount: int64;
Begin
p:=(t.sec shr 1)+(t.min shl 5)+(t.hour shl 11)+(t.day shl 16)+(t.month shl 21)+((t.year-1980) shl 25);
End;
Procedure unpacktime(p : longint;var t : datetime);
Begin
with t do
begin begin
sec:=(p and 31) shl 1; GetMsCount := MemL [$40:$6c] * 55;
min:=(p shr 5) and 63;
hour:=(p shr 11) and 31;
day:=(p shr 16) and 31;
month:=(p shr 21) and 15;
year:=(p shr 25)+1980;
end; end;
End;
{****************************************************************************** {******************************************************************************
--- Exec --- --- Exec ---
******************************************************************************} ******************************************************************************}
{$ifdef HASTHREADVAR}
threadvar
{$else HASTHREADVAR}
var
{$endif HASTHREADVAR}
lastdosexitcode : word;
procedure exec(const path : pathstr;const comline : comstr); procedure exec(const path : pathstr;const comline : comstr);
type type
realptr = packed record realptr = packed record
@ -296,12 +282,6 @@ begin
end; end;
function dosexitcode : word;
begin
dosexitcode:=lastdosexitcode;
end;
procedure getcbreak(var breakvalue : boolean); procedure getcbreak(var breakvalue : boolean);
begin begin
dosregs.ax:=$3300; dosregs.ax:=$3300;
@ -640,78 +620,6 @@ end;
--- File --- --- File ---
******************************************************************************} ******************************************************************************}
procedure fsplit(path : pathstr;var dir : dirstr;var name : namestr;var ext : extstr);
var
dotpos,p1,i : longint;
begin
{ allow slash as backslash }
for i:=1 to length(path) do
if path[i]='/' then path[i]:='\';
{ get drive name }
p1:=pos(':',path);
if p1>0 then
begin
dir:=path[1]+':';
delete(path,1,p1);
end
else
dir:='';
{ split the path and the name, there are no more path informtions }
{ if path contains no backslashes }
while true do
begin
p1:=pos('\',path);
if p1=0 then
break;
dir:=dir+copy(path,1,p1);
delete(path,1,p1);
end;
{ try to find out a extension }
if LFNSupport then
begin
Ext:='';
i:=Length(Path);
DotPos:=256;
While (i>0) Do
Begin
If (Path[i]='.') Then
begin
DotPos:=i;
break;
end;
Dec(i);
end;
Ext:=Copy(Path,DotPos,255);
Name:=Copy(Path,1,DotPos - 1);
end
else
begin
p1:=pos('.',path);
if p1>0 then
begin
ext:=copy(path,p1,4);
delete(path,p1,length(path)-p1+1);
end
else
ext:='';
name:=path;
end;
end;
(*
function FExpand (const Path: PathStr): PathStr;
- declared in fexpand.inc
*)
{$DEFINE FPC_FEXPAND_UNC} (* UNC paths are supported *)
{$DEFINE FPC_FEXPAND_DRIVES} (* Full paths begin with drive specification *)
{$I fexpand.inc}
{$UNDEF FPC_FEXPAND_DRIVES}
{$UNDEF FPC_FEXPAND_UNC}
Function FSearch(path: pathstr; dirlist: string): pathstr; Function FSearch(path: pathstr; dirlist: string): pathstr;
var var
@ -930,27 +838,13 @@ begin
end; end;
{******************************************************************************
--- Not Supported ---
******************************************************************************}
Procedure keep(exitcode : word);
Begin
End;
Procedure getintvec(intno : byte;var vector : pointer);
Begin
End;
Procedure setintvec(intno : byte;vector : pointer);
Begin
End;
end. end.
{ {
$Log$ $Log$
Revision 1.21 2004-02-17 17:37:26 daniel Revision 1.22 2004-12-05 16:44:43 hajny
* GetMsCount added, platform independent routines moved to single include file
Revision 1.21 2004/02/17 17:37:26 daniel
* Enable threadvars again * Enable threadvars again
Revision 1.20 2004/02/16 22:16:59 hajny Revision 1.20 2004/02/16 22:16:59 hajny

17
rtl/inc/dos.inc
View File

@ -29,7 +29,6 @@ var
{$ENDIF HASTHREADVAR} {$ENDIF HASTHREADVAR}
LastDosExitCode: longint; LastDosExitCode: longint;
function DosExitCode: word; function DosExitCode: word;
begin begin
if LastDosExitCode > high (word) then if LastDosExitCode > high (word) then
@ -108,16 +107,25 @@ end;
{$IFNDEF HAS_GETVERIFY} {$IFNDEF HAS_GETVERIFY}
var
VerifyValue: boolean;
procedure GetVerify (var Verify: boolean); procedure GetVerify (var Verify: boolean);
begin begin
Verify := true; Verify := VerifyValue;
end; end;
{$ENDIF HAS_GETVERIFY} {$ENDIF HAS_GETVERIFY}
{$IFNDEF HAS_SETVERIFY} {$IFNDEF HAS_SETVERIFY}
{$IFDEF HAS_GETVERIFY}
var
VerifyValue: boolean;
{$ENDIF HAS_GETVERIFY}
procedure SetVerify (Verify: boolean); procedure SetVerify (Verify: boolean);
begin begin
VerifyValue := Verify;
end; end;
{$ENDIF HAS_SETVERIFY} {$ENDIF HAS_SETVERIFY}
@ -290,7 +298,10 @@ end;
{ {
$Log$ $Log$
Revision 1.1 2004-11-28 12:33:35 hajny Revision 1.2 2004-12-05 16:44:43 hajny
* GetMsCount added, platform independent routines moved to single include file
Revision 1.1 2004/11/28 12:33:35 hajny
* common implementation of platform independent functions for unit Dos * common implementation of platform independent functions for unit Dos

150
rtl/macos/dos.pp
View File

@ -19,10 +19,6 @@ Uses
macostp; macostp;
Const
{Max PathName Length for files}
FileNameLen=255;
Type Type
SearchRec = packed record SearchRec = packed record
Attr: Byte; {attribute of found file} Attr: Byte; {attribute of found file}
@ -65,6 +61,19 @@ Uses
macutils, macutils,
unixutil {for FNMatch}; unixutil {for FNMatch};
{$UNDEF USE_FEXPAND_INC}
{$IFNDEF USE_FEXPAND_INC}
{$DEFINE HAS_FEXPAND}
{$ENDIF USE_FEXPAND_INC}
{$DEFINE FPC_FEXPAND_VOLUMES}
{$DEFINE FPC_FEXPAND_NO_DEFAULT_PATHS}
{$DEFINE FPC_FEXPAND_DRIVESEP_IS_ROOT}
{$I dos.inc}
function MacTimeToDosPackedTime(macfiletime: UInt32): Longint; function MacTimeToDosPackedTime(macfiletime: UInt32): Longint;
var var
mdt: DateTimeRec; {Mac OS datastructure} mdt: DateTimeRec; {Mac OS datastructure}
@ -125,21 +134,6 @@ begin
sec100 := 0; sec100 := 0;
end; end;
procedure Packtime(var t : datetime;var p : longint);
Begin
p:=(t.sec shr 1)+(t.min shl 5)+(t.hour shl 11)+(t.day shl 16)+(t.month shl 21)+((t.year-1980) shl 25);
End;
procedure Unpacktime(p : longint;var t : datetime);
Begin
t.sec:=(p and 31) shl 1;
t.min:=(p shr 5) and 63;
t.hour:=(p shr 11) and 31;
t.day:=(p shr 16) and 31;
t.month:=(p shr 21) and 15;
t.year:=(p shr 25)+1980;
End;
Procedure SetDate(Year, Month, Day: Word); Procedure SetDate(Year, Month, Day: Word);
var var
@ -277,13 +271,6 @@ begin
ExecuteToolserverScript:= err; ExecuteToolserverScript:= err;
end; end;
{$ifdef HASTHREADVAR}
threadvar
{$else HASTHREADVAR}
var
{$endif HASTHREADVAR}
laststatuscode : longint;
Procedure Exec (Const Path: PathStr; Const ComLine: ComStr); Procedure Exec (Const Path: PathStr; Const ComLine: ComStr);
var var
s: AnsiString; s: AnsiString;
@ -294,13 +281,13 @@ Begin
{Make ToolServers working directory in sync with our working directory} {Make ToolServers working directory in sync with our working directory}
PathArgToFullPath(':', wdpath); PathArgToFullPath(':', wdpath);
wdpath:= 'Directory ' + wdpath; wdpath:= 'Directory ' + wdpath;
err:= ExecuteToolserverScript(PChar(wdpath), laststatuscode); err:= ExecuteToolserverScript(PChar(wdpath), LastDosExitCode);
{TODO Only change path when actually needed. But this requires some {TODO Only change path when actually needed. But this requires some
change counter to be incremented each time wd is changed. } change counter to be incremented each time wd is changed. }
s:= path + ' ' + comline; s:= path + ' ' + comline;
err:= ExecuteToolserverScript(PChar(s), laststatuscode); err:= ExecuteToolserverScript(PChar(s), LastDosExitCode);
if err = afpItemNotFound then if err = afpItemNotFound then
DosError := 900 DosError := 900
else else
@ -308,21 +295,6 @@ Begin
//TODO Better dos error codes //TODO Better dos error codes
End; End;
Function DosExitCode: Word;
var
clippedstatus: Word;
Begin
if laststatuscode <> 0 then
begin
{MPW status might be 24 bits}
clippedstatus := laststatuscode and $ffff;
if clippedstatus = 0 then
clippedstatus:= 1;
DosExitCode:= clippedstatus;
end
else
DosExitCode := 0;
End;
{****************************************************************************** {******************************************************************************
--- Disk --- --- Disk ---
@ -785,26 +757,7 @@ End;
end; end;
{$UNDEF USE_FEXPAND_INC} {$IFNDEF USE_FEXPAND_INC}
{$IFDEF USE_FEXPAND_INC}
{$DEFINE FPC_FEXPAND_VOLUMES}
{$DEFINE FPC_FEXPAND_NO_DEFAULT_PATHS}
{$DEFINE FPC_FEXPAND_DRIVESEP_IS_ROOT}
{ TODO A lot of issues before this works}
{$I fexpand.inc}
{$UNDEF FPC_FEXPAND_VOLUMES}
{$UNDEF FPC_FEXPAND_NO_DEFAULT_PATHS}
{$UNDEF FPC_FEXPAND_DRIVESEP_IS_ROOT}
{$ELSE}
{ TODO nonexisting dirs in path's doesnt work (nonexisting files do work) { TODO nonexisting dirs in path's doesnt work (nonexisting files do work)
example: Writeln('FExpand on :nisse:kalle : ', FExpand(':nisse:kalle')); } example: Writeln('FExpand on :nisse:kalle : ', FExpand(':nisse:kalle')); }
@ -817,29 +770,8 @@ End;
FExpand:= fullpath; FExpand:= fullpath;
end; end;
{$ENDIF} {$ENDIF USE_FEXPAND_INC}
procedure FSplit (path: pathstr; var dir: dirstr; var name: namestr; var ext: extstr);
var
dotPos,colonPos,i : longint;
begin
colonPos:=0;
dotPos:=256;
i:=Length(path);
while (i>0) and (colonPos=0) Do
begin
If (dotPos=256) and (path[i]='.') Then
dotPos:=i;
If (path[i]=':') Then
colonPos:=i;
Dec(i);
end;
ext:=Copy(path,dotPos,255);
dir:=Copy(path,1,colonPos);
name:=Copy(path,colonPos + 1,dotPos - colonPos - 1);
end;
procedure GetFTime (var f ; var time: longint); procedure GetFTime (var f ; var time: longint);
@ -998,64 +930,28 @@ Begin
GetEnv:=StrPas(p); GetEnv:=StrPas(p);
End; End;
{****************************************************************************** {
--- Do Nothing Procedures/Functions ---
******************************************************************************}
Procedure getintvec(intno : byte;var vector : pointer);
Begin
{! No MacOS equivalent !}
End;
Procedure setintvec(intno : byte;vector : pointer);
Begin
{! No MacOS equivalent !}
End;
Procedure SwapVectors;
Begin
{! No MacOS equivalent !}
End;
Procedure Keep(exitcode : word);
Begin
{! No MacOS equivalent !}
End;
Procedure GetCBreak(Var BreakValue: Boolean); Procedure GetCBreak(Var BreakValue: Boolean);
Begin Begin
{! Might be implemented in future on MacOS to handle Cmd-. (period) key press} -- Might be implemented in future on MacOS to handle Cmd-. (period) key press
breakvalue:=true
End; End;
Procedure SetCBreak(BreakValue: Boolean); Procedure SetCBreak(BreakValue: Boolean);
Begin Begin
{! Might be implemented in future on MacOS to handle Cmd-. (period) key press} -- Might be implemented in future on MacOS to handle Cmd-. (period) key press
End; End;
Procedure GetVerify(Var Verify: Boolean); Procedure GetVerify(Var Verify: Boolean);
Begin Begin
{! Might be implemented in future on MacOS} -- Might be implemented in future on MacOS
Verify:=true;
End; End;
Procedure SetVerify(Verify: Boolean); Procedure SetVerify(Verify: Boolean);
Begin Begin
{! Might be implemented in future on MacOS} -- Might be implemented in future on MacOS
End; End;
}
function GetShortName(var p : String) : boolean;
begin
{ short=long under MacOS}
GetShortName:=True;
end;
function GetLongName(var p : String) : boolean;
begin
{ short=long under MacOS}
GetLongName:=True;
end;
{****************************************************************************** {******************************************************************************
--- Initialization --- --- Initialization ---

278
rtl/morphos/dos.pp
View File

@ -32,49 +32,6 @@ unit Dos;
interface interface
const
{Bitmasks for CPU Flags}
fcarry = $0001;
fparity = $0004;
fauxiliary = $0010;
fzero = $0040;
fsign = $0080;
foverflow = $0800;
{Bitmasks for file attribute}
readonly = $01;
hidden = $02;
sysfile = $04;
volumeid = $08;
directory = $10;
archive = $20;
anyfile = $3F;
{File Status}
fmclosed = $D7B0;
fminput = $D7B1;
fmoutput = $D7B2;
fminout = $D7B3;
Type
ComStr = String[255]; { size increased to be more compatible with Unix}
PathStr = String[255]; { size increased to be more compatible with Unix}
DirStr = String[255]; { size increased to be more compatible with Unix}
NameStr = String[255]; { size increased to be more compatible with Unix}
ExtStr = String[255]; { size increased to be more compatible with Unix}
{
filerec.inc contains the definition of the filerec.
textrec.inc contains the definition of the textrec.
It is in a separate file to make it available in other units without
having to use the DOS unit for it.
}
{$i filerec.inc}
{$i textrec.inc}
type type
SearchRec = Packed Record SearchRec = Packed Record
{ watch out this is correctly aligned for all processors } { watch out this is correctly aligned for all processors }
@ -89,81 +46,20 @@ type
Name : String[255]; {name of found file} Name : String[255]; {name of found file}
End; End;
{$I dosh.inc}
DateTime = packed record
Year : Word;
Month: Word;
Day : Word;
Hour : Word;
Min : Word;
Sec : Word;
End;
{ Some ugly x86 registers... }
registers = packed record
case i : integer of
0 : (ax,f1,bx,f2,cx,f3,dx,f4,bp,f5,si,f51,di,f6,ds,f7,es,f8,flags,fs,gs : word);
1 : (al,ah,f9,f10,bl,bh,f11,f12,cl,ch,f13,f14,dl,dh : byte);
2 : (eax, ebx, ecx, edx, ebp, esi, edi : longint);
end;
var
DosError : integer;
{Interrupt}
Procedure Intr(intno: byte; var regs: registers);
Procedure MSDos(var regs: registers);
{Info/Date/Time}
Function DosVersion: Word;
Procedure GetDate(var year, month, mday, wday: word);
Procedure GetTime(var hour, minute, second, sec100: word);
procedure SetDate(year,month,day: word);
Procedure SetTime(hour,minute,second,sec100: word);
Procedure UnpackTime(p: longint; var t: datetime);
Procedure PackTime(var t: datetime; var p: longint);
{Exec}
Procedure Exec(const path: pathstr; const comline: comstr);
Function DosExitCode: word;
{Disk}
Function DiskFree(drive: byte) : longint;
Function DiskSize(drive: byte) : longint;
Procedure FindFirst(path: pathstr; attr: word; var f: searchRec);
Procedure FindNext(var f: searchRec);
Procedure FindClose(Var f: SearchRec);
{File}
Procedure GetFAttr(var f; var attr: word);
Procedure GetFTime(var f; var time: longint);
Function FSearch(path: pathstr; dirlist: string): pathstr;
Function FExpand(const path: pathstr): pathstr;
Procedure FSplit(path: pathstr; var dir: dirstr; var name: namestr; var ext: extstr);
{Environment}
Function EnvCount: longint;
Function EnvStr(index: integer): string;
Function GetEnv(envvar: string): string;
{Misc}
Procedure SetFAttr(var f; attr: word);
Procedure SetFTime(var f; time: longint);
Procedure GetCBreak(var breakvalue: boolean);
Procedure SetCBreak(breakvalue: boolean);
Procedure GetVerify(var verify: boolean);
Procedure SetVerify(verify: boolean);
{Do Nothing Functions}
Procedure SwapVectors;
Procedure GetIntVec(intno: byte; var vector: pointer);
Procedure SetIntVec(intno: byte; vector: pointer);
Procedure Keep(exitcode: word);
implementation implementation
{$DEFINE HAS_GETMSCOUNT}
{$DEFINE HAS_GETCBREAK}
{$DEFINE HAS_SETSBREAK}
{$DEFINE FPC_FEXPAND_VOLUMES} (* Full paths begin with drive specification *)
{$DEFINE FPC_FEXPAND_DRIVESEP_IS_ROOT}
{$DEFINE FPC_FEXPAND_NO_DEFAULT_PATHS}
{$I dos.inc}
{ * include MorphOS specific functions & definitions * } { * include MorphOS specific functions & definitions * }
{$include execd.inc} {$include execd.inc}
@ -212,38 +108,6 @@ begin
BSTR2STRING:=Pointer(Longint(BADDR(s))+1); BSTR2STRING:=Pointer(Longint(BADDR(s))+1);
end; end;
Procedure AmigaToDt(SecsPast: LongInt; Var Dt: DateTime);
var
cd : pClockData;
Begin
New(cd);
Amiga2Date(SecsPast,cd);
Dt.sec := cd^.sec;
Dt.min := cd^.min;
Dt.hour := cd^.hour;
Dt.day := cd^.mday;
Dt.month := cd^.month;
Dt.year := cd^.year;
Dispose(cd);
End;
Function DtToAmiga(DT: DateTime): LongInt;
var
cd : pClockData;
temp : Longint;
Begin
New(cd);
cd^.sec := Dt.sec;
cd^.min := Dt.min;
cd^.hour := Dt.hour;
cd^.mday := Dt.day;
cd^.month := Dt.month;
cd^.year := Dt.year;
temp := Date2Amiga(cd);
Dispose(cd);
DtToAmiga := temp;
end;
function IsLeapYear(Source : Word) : Boolean; function IsLeapYear(Source : Word) : Boolean;
begin begin
if (source Mod 400 = 0) or ((source Mod 4 = 0) and (source Mod 100 <> 0)) then if (source Mod 400 = 0) or ((source Mod 4 = 0) and (source Mod 100 <> 0)) then
@ -324,36 +188,6 @@ begin
end; end;
{******************************************************************************
--- Dos Interrupt ---
******************************************************************************}
procedure Intr(intno: byte; var regs: registers);
begin
{ Does not apply to MorphOS - not implemented }
end;
procedure SwapVectors;
begin
{ Does not apply to MorphOS - Do Nothing }
end;
procedure msdos(var regs : registers);
begin
{ ! Not implemented in MorphOS ! }
end;
procedure getintvec(intno : byte;var vector : pointer);
begin
{ ! Not implemented in MorphOS ! }
end;
procedure setintvec(intno : byte;vector : pointer);
begin
{ ! Not implemented in MorphOS ! }
end;
{****************************************************************************** {******************************************************************************
--- Info / Date / Time --- --- Info / Date / Time ---
******************************************************************************} ******************************************************************************}
@ -588,28 +422,20 @@ Begin
dispose(cd); dispose(cd);
End; End;
Procedure unpacktime(p : longint;var t : datetime);
Begin
AmigaToDt(p,t);
End;
function GetMsCount: int64;
Procedure packtime(var t : datetime;var p : longint); var
Begin TV: TTimeVal;
p := DtToAmiga(t); begin
Get_Sys_Time (@TV);
GetMsCount := TV.TV_Secs * 1000 + TV.TV_Micro div 1000;
end; end;
{****************************************************************************** {******************************************************************************
--- Exec --- --- Exec ---
******************************************************************************} ******************************************************************************}
Var
LastDosExitCode: word;
Ver : Boolean;
Procedure Exec (Const Path: PathStr; Const ComLine: ComStr); Procedure Exec (Const Path: PathStr; Const ComLine: ComStr);
var var
p : string; p : string;
@ -649,12 +475,6 @@ Procedure Exec (Const Path: PathStr; Const ComLine: ComStr);
End; End;
Function DosExitCode: Word;
Begin
DosExitCode:=LastdosExitCode;
End;
Procedure GetCBreak(Var BreakValue: Boolean); Procedure GetCBreak(Var BreakValue: Boolean);
Begin Begin
breakvalue := system.BreakOn; breakvalue := system.BreakOn;
@ -667,17 +487,6 @@ Function DosExitCode: Word;
End; End;
Procedure GetVerify(Var Verify: Boolean);
Begin
verify:=ver;
End;
Procedure SetVerify(Verify: Boolean);
Begin
ver:=Verify;
End;
{****************************************************************************** {******************************************************************************
--- Disk --- --- Disk ---
******************************************************************************} ******************************************************************************}
@ -939,44 +748,6 @@ End;
{****************************************************************************** {******************************************************************************
--- File --- --- File ---
******************************************************************************} ******************************************************************************}
Procedure FSplit(path: pathstr; var dir: dirstr; var name: namestr; var ext: extstr);
var
I: Word;
begin
{ allow backslash as slash }
for i:=1 to length(path) do
if path[i]='\' then path[i]:='/';
I := Length(Path);
while (I > 0) and not ((Path[I] = '/') or (Path[I] = ':'))
do Dec(I);
if Path[I] = '/' then
dir := Copy(Path, 0, I)
else dir := Copy(Path,0,I);
if Length(Path) > Length(dir) then
name := Copy(Path, I + 1, Length(Path)-I)
else
name := '';
{ Remove extension }
if pos('.',name) <> 0 then
begin
ext:=copy(name,pos('.',name),length(name));
delete(name,pos('.',name),length(name));
end
else
ext := '';
end;
{$DEFINE FPC_FEXPAND_VOLUMES} (* Full paths begin with drive specification *)
{$DEFINE FPC_FEXPAND_DRIVESEP_IS_ROOT}
{$DEFINE FPC_FEXPAND_NO_DEFAULT_PATHS}
{$I fexpand.inc}
{$UNDEF FPC_FEXPAND_VOLUMES} (* Full paths begin with drive specification *)
{$UNDEF FPC_FEXPAND_DRIVESEP_IS_ROOT}
{$UNDEF FPC_FEXPAND_NO_DEFAULT_PATHS}
function FSearch(path: PathStr; dirlist: String) : PathStr; function FSearch(path: PathStr; dirlist: String) : PathStr;
var var
@ -1242,15 +1013,6 @@ begin
end; end;
{******************************************************************************
--- Not Supported ---
******************************************************************************}
Procedure keep(exitcode : word);
Begin
{ ! Not implemented in MorphOS ! }
End;
procedure AddDevice(str : String); procedure AddDevice(str : String);
begin begin
inc(numberofdevices); inc(numberofdevices);
@ -1304,7 +1066,6 @@ end;
Begin Begin
DosError:=0; DosError:=0;
ver := TRUE;
numberofdevices := 0; numberofdevices := 0;
StrOfPaths := ''; StrOfPaths := '';
ReadInDevices; ReadInDevices;
@ -1312,7 +1073,10 @@ End.
{ {
$Log$ $Log$
Revision 1.10 2004-11-23 02:57:58 karoly Revision 1.11 2004-12-05 16:44:43 hajny
* GetMsCount added, platform independent routines moved to single include file
Revision 1.10 2004/11/23 02:57:58 karoly
* Fixed missing $INLINE * Fixed missing $INLINE
Revision 1.9 2004/11/18 22:30:33 karoly Revision 1.9 2004/11/18 22:30:33 karoly

181
rtl/netware/dos.pp
View File

@ -17,9 +17,6 @@
unit dos; unit dos;
interface interface
Const
FileNameLen = 255;
Type Type
searchrec = packed record searchrec = packed record
DirP : POINTER; { used for opendir } DirP : POINTER; { used for opendir }
@ -33,19 +30,24 @@ Type
name : string[255]; { NW uses only [12] but more can't hurt } name : string[255]; { NW uses only [12] but more can't hurt }
end; end;
registers = packed record
case i : integer of
0 : (ax,f1,bx,f2,cx,f3,dx,f4,bp,f5,si,f51,di,f6,ds,f7,es,f8,flags,fs,gs : word);
1 : (al,ah,f9,f10,bl,bh,f11,f12,cl,ch,f13,f14,dl,dh : byte);
2 : (eax, ebx, ecx, edx, ebp, esi, edi : longint);
end;
{$i dosh.inc} {$i dosh.inc}
implementation implementation
uses uses
strings; strings, nwserv;
{$DEFINE HAS_GETMSCOUNT}
{$DEFINE HAS_GETCBREAK}
{$DEFINE HAS_SETSBREAK}
{$DEFINE HAS_KEEP}
{$define FPC_FEXPAND_DRIVES}
{$define FPC_FEXPAND_VOLUMES}
{$define FPC_FEXPAND_NO_DEFAULT_PATHS}
{$I dos.inc}
{$ASMMODE ATT} {$ASMMODE ATT}
{$I nwsys.inc } {$I nwsys.inc }
@ -102,37 +104,16 @@ begin
end; end;
Procedure packtime(var t : datetime;var p : longint); function GetMsCount: int64;
Begin
p:=(t.sec shr 1)+(t.min shl 5)+(t.hour shl 11)+(t.day shl 16)+(t.month shl 21)+((t.year-1980) shl 25);
End;
Procedure unpacktime(p : longint;var t : datetime);
Begin
with t do
begin begin
sec:=(p and 31) shl 1; GetMsCount := Nwserv.GetCurrentTicks * 55;
min:=(p shr 5) and 63;
hour:=(p shr 11) and 31;
day:=(p shr 16) and 31;
month:=(p shr 21) and 15;
year:=(p shr 25)+1980;
end; end;
End;
{****************************************************************************** {******************************************************************************
--- Exec --- --- Exec ---
******************************************************************************} ******************************************************************************}
{$ifdef HASTHREADVAR}
threadvar
{$else HASTHREADVAR}
var
{$endif HASTHREADVAR}
lastdosexitcode : word;
const maxargs=256; const maxargs=256;
procedure exec(const path : pathstr;const comline : comstr); procedure exec(const path : pathstr;const comline : comstr);
var c : comstr; var c : comstr;
@ -174,12 +155,6 @@ end;
function dosexitcode : word;
begin
dosexitcode:=lastdosexitcode;
end;
procedure getcbreak(var breakvalue : boolean); procedure getcbreak(var breakvalue : boolean);
begin begin
breakvalue := _SetCtrlCharCheckMode (false); { get current setting } breakvalue := _SetCtrlCharCheckMode (false); { get current setting }
@ -194,17 +169,6 @@ begin
end; end;
procedure getverify(var verify : boolean);
begin
verify := true;
end;
procedure setverify(verify : boolean);
begin
end;
{****************************************************************************** {******************************************************************************
--- Disk --- --- Disk ---
******************************************************************************} ******************************************************************************}
@ -383,90 +347,10 @@ begin
end; end;
procedure swapvectors;
begin
end;
{****************************************************************************** {******************************************************************************
--- File --- --- File ---
******************************************************************************} ******************************************************************************}
procedure fsplit(path : pathstr;var dir : dirstr;var name : namestr;var ext : extstr);
var
dotpos,p1,i : longint;
begin
{ allow backslash as slash }
for i:=1 to length(path) do
if path[i]='\' then path[i]:='/';
{ get volume name }
p1:=pos(':',path);
if p1>0 then
begin
dir:=copy(path,1,p1);
delete(path,1,p1);
end
else
dir:='';
{ split the path and the name, there are no more path informtions }
{ if path contains no backslashes }
while true do
begin
p1:=pos('/',path);
if p1=0 then
break;
dir:=dir+copy(path,1,p1);
delete(path,1,p1);
end;
{ try to find out a extension }
//if LFNSupport then
begin
Ext:='';
i:=Length(Path);
DotPos:=256;
While (i>0) Do
Begin
If (Path[i]='.') Then
begin
DotPos:=i;
break;
end;
Dec(i);
end;
Ext:=Copy(Path,DotPos,255);
Name:=Copy(Path,1,DotPos - 1);
end
(* else
begin
p1:=pos('.',path);
if p1>0 then
begin
ext:=copy(path,p1,4);
delete(path,p1,length(path)-p1+1);
end
else
ext:='';
name:=path;
end;*)
end;
function GetShortName(var p : String) : boolean;
begin
GetShortName := false;
end;
function GetLongName(var p : String) : boolean;
begin
GetLongName := false;
end;
{$define FPC_FEXPAND_DRIVES}
{$define FPC_FEXPAND_VOLUMES}
{$define FPC_FEXPAND_NO_DEFAULT_PATHS}
{$i fexpand.inc}
Function FSearch(path: pathstr; dirlist: string): pathstr; Function FSearch(path: pathstr; dirlist: string): pathstr;
var var
i,p1 : longint; i,p1 : longint;
@ -590,15 +474,25 @@ begin
i := 1; i := 1;
res := _NWGetSearchPathElement (i, isdosPath, @envvar0[0]); res := _NWGetSearchPathElement (i, isdosPath, @envvar0[0]);
while res = 0 do while res = 0 do
begin begin
if GetEnv <> '' then GetEnv := GetEnv + ';'; if GetEnv <> '' then GetEnv := GetEnv + ';';
GetEnv := GetEnv + envvar0; GetEnv := GetEnv + envvar0;
inc (i); inc (i);
res := _NWGetSearchPathElement (i, isdosPath, @envvar0[0]); res := _NWGetSearchPathElement (i, isdosPath, @envvar0[0]);
end; end;
for i := 1 to length(GetEnv) do for i := 1 to length(GetEnv) do
if GetEnv[i] = '\' then if GetEnv[i] = '\' then
GetEnv[i] := '/'; GetEnv[i] := '/';
end else end else
begin begin
strpcopy(envvar0,envvar); strpcopy(envvar0,envvar);
@ -621,31 +515,14 @@ Begin
while true do _delay (60000); while true do _delay (60000);
End; End;
Procedure getintvec(intno : byte;var vector : pointer);
Begin
{ no netware equivalent }
End;
Procedure setintvec(intno : byte;vector : pointer);
Begin
{ no netware equivalent }
End;
procedure intr(intno : byte;var regs : registers);
begin
{ no netware equivalent }
end;
procedure msdos(var regs : registers);
begin
{ no netware equivalent }
end;
end. end.
{ {
$Log$ $Log$
Revision 1.11 2004-08-01 20:02:48 armin Revision 1.12 2004-12-05 16:44:43 hajny
* GetMsCount added, platform independent routines moved to single include file
Revision 1.11 2004/08/01 20:02:48 armin
* changed dir separator from \ to / * changed dir separator from \ to /
* long namespace by default * long namespace by default
* dos.exec implemented * dos.exec implemented

169
rtl/netwlibc/dos.pp
View File

@ -19,9 +19,6 @@ interface
uses libc; uses libc;
Const
FileNameLen = 255;
Type Type
searchrec = packed record searchrec = packed record
DirP : POINTER; { used for opendir } DirP : POINTER; { used for opendir }
@ -38,13 +35,6 @@ Type
_attr : word; _attr : word;
end; end;
registers = packed record
case i : integer of
0 : (ax,f1,bx,f2,cx,f3,dx,f4,bp,f5,si,f51,di,f6,ds,f7,es,f8,flags,fs,gs : word);
1 : (al,ah,f9,f10,bl,bh,f11,f12,cl,ch,f13,f14,dl,dh : byte);
2 : (eax, ebx, ecx, edx, ebp, esi, edi : longint);
end;
{$i dosh.inc} {$i dosh.inc}
{Extra Utils} {Extra Utils}
function weekday(y,m,d : longint) : longint; function weekday(y,m,d : longint) : longint;
@ -55,6 +45,16 @@ implementation
uses uses
strings; strings;
{$DEFINE HAS_GETMSCOUNT}
{$DEFINE HAS_KEEP}
{$DEFINE FPC_FEXPAND_DRIVES}
{$DEFINE FPC_FEXPAND_VOLUMES}
{$DEFINE FPC_FEXPAND_NO_DEFAULT_PATHS}
{$i dos.inc}
{$ASMMODE ATT} {$ASMMODE ATT}
{***************************************************************************** {*****************************************************************************
@ -138,37 +138,20 @@ begin
end; end;
Procedure packtime(var t : datetime;var p : longint); function GetMsCount: int64;
Begin var
p:=(t.sec shr 1)+(t.min shl 5)+(t.hour shl 11)+(t.day shl 16)+(t.month shl 21)+((t.year-1980) shl 25); tv : TimeVal;
End; tz : TimeZone;
Procedure unpacktime(p : longint;var t : datetime);
Begin
with t do
begin begin
sec:=(p and 31) shl 1; FPGetTimeOfDay (tv, tz);
min:=(p shr 5) and 63; GetMsCount := tv.tv_Sec * 1000 + tv.tv_uSec div 1000;
hour:=(p shr 11) and 31;
day:=(p shr 16) and 31;
month:=(p shr 21) and 15;
year:=(p shr 25)+1980;
end; end;
End;
{****************************************************************************** {******************************************************************************
--- Exec --- --- Exec ---
******************************************************************************} ******************************************************************************}
{$ifdef HASTHREADVAR}
threadvar
{$else HASTHREADVAR}
var
{$endif HASTHREADVAR}
lastdosexitcode : word;
const maxargs=256; const maxargs=256;
procedure exec(const path : pathstr;const comline : comstr); procedure exec(const path : pathstr;const comline : comstr);
var c : comstr; var c : comstr;
@ -228,33 +211,6 @@ end;
function dosexitcode : word;
begin
dosexitcode:=lastdosexitcode;
end;
procedure getcbreak(var breakvalue : boolean);
begin
end;
procedure setcbreak(breakvalue : boolean);
begin
end;
procedure getverify(var verify : boolean);
begin
verify := true;
end;
procedure setverify(verify : boolean);
begin
end;
{****************************************************************************** {******************************************************************************
--- Disk --- --- Disk ---
******************************************************************************} ******************************************************************************}
@ -493,78 +449,10 @@ begin
end; end;
procedure swapvectors;
begin
end;
{****************************************************************************** {******************************************************************************
--- File --- --- File ---
******************************************************************************} ******************************************************************************}
procedure fsplit(path : pathstr;var dir : dirstr;var name : namestr;var ext : extstr);
var
dotpos,p1,i : longint;
begin
{ allow backslash as slash }
for i:=1 to length(path) do
if path[i]='\' then path[i]:='/';
{ get volume name }
p1:=pos(':',path);
if p1>0 then
begin
dir:=copy(path,1,p1);
delete(path,1,p1);
end
else
dir:='';
{ split the path and the name, there are no more path informtions }
{ if path contains no backslashes }
while true do
begin
p1:=pos('/',path);
if p1=0 then
break;
dir:=dir+copy(path,1,p1);
delete(path,1,p1);
end;
{ try to find out a extension }
//if LFNSupport then
begin
Ext:='';
i:=Length(Path);
DotPos:=256;
While (i>0) Do
Begin
If (Path[i]='.') Then
begin
DotPos:=i;
break;
end;
Dec(i);
end;
Ext:=Copy(Path,DotPos,255);
Name:=Copy(Path,1,DotPos - 1);
end
end;
function GetShortName(var p : String) : boolean;
begin
GetShortName := false;
end;
function GetLongName(var p : String) : boolean;
begin
GetLongName := false;
end;
{$define FPC_FEXPAND_DRIVES}
{$define FPC_FEXPAND_VOLUMES}
{$define FPC_FEXPAND_NO_DEFAULT_PATHS}
{$i fexpand.inc}
Function FSearch(path: pathstr; dirlist: string): pathstr; Function FSearch(path: pathstr; dirlist: string): pathstr;
var var
i,p1 : longint; i,p1 : longint;
@ -798,31 +686,14 @@ Begin
while true do delay (60000); while true do delay (60000);
End; End;
Procedure getintvec(intno : byte;var vector : pointer);
Begin
{ no netware equivalent }
End;
Procedure setintvec(intno : byte;vector : pointer);
Begin
{ no netware equivalent }
End;
procedure intr(intno : byte;var regs : registers);
begin
{ no netware equivalent }
end;
procedure msdos(var regs : registers);
begin
{ no netware equivalent }
end;
end. end.
{ {
$Log$ $Log$
Revision 1.4 2004-09-26 19:23:34 armin Revision 1.5 2004-12-05 16:44:43 hajny
* GetMsCount added, platform independent routines moved to single include file
Revision 1.4 2004/09/26 19:23:34 armin
* exiting threads at nlm unload * exiting threads at nlm unload
* renamed some libc functions * renamed some libc functions

199
rtl/unix/dos.pp
View File

@ -15,10 +15,6 @@
Unit Dos; Unit Dos;
Interface Interface
Const
{Max FileName Length for files}
FileNameLen=255;
Type Type
SearchRec = SearchRec =
@ -43,16 +39,6 @@ Type
NamePos : Word; {end of path, start of name position} NamePos : Word; {end of path, start of name position}
End; End;
{$ifdef cpui386}
Registers = packed record
case i : integer of
0 : (ax,f1,bx,f2,cx,f3,dx,f4,bp,f5,si,f51,di,f6,ds,f7,es,f8,flags,fs,gs : word);
1 : (al,ah,f9,f10,bl,bh,f11,f12,cl,ch,f13,f14,dl,dh : byte);
2 : (eax, ebx, ecx, edx, ebp, esi, edi : longint);
End;
{$endif cpui386}
{$i dosh.inc} {$i dosh.inc}
{Extra Utils} {Extra Utils}
@ -68,6 +54,14 @@ Implementation
Uses Uses
Strings,Unix,BaseUnix,{$ifdef FPC_USE_LIBC}initc{$ELSE}Syscall{$ENDIF}; Strings,Unix,BaseUnix,{$ifdef FPC_USE_LIBC}initc{$ELSE}Syscall{$ENDIF};
{$DEFINE HAS_GETMSCOUNT}
{$DEFINE FPC_FEXPAND_TILDE} { Tilde is expanded to home }
{$DEFINE FPC_FEXPAND_GETENVPCHAR} { GetEnv result is a PChar }
{$I dos.inc}
{$ifndef FPC_USE_LIBC} {$ifndef FPC_USE_LIBC}
{$i sysnr.inc} {$i sysnr.inc}
{$endif} {$endif}
@ -261,6 +255,7 @@ begin
fpSettimeofday(@tv,nil); fpSettimeofday(@tv,nil);
end; end;
Function SetDateTime(Year,Month,Day,hour,minute,second:Word) : Boolean; Function SetDateTime(Year,Month,Day,hour,minute,second:Word) : Boolean;
var var
tv : timeval; tv : timeval;
@ -269,6 +264,7 @@ begin
SetDatetime:=fpSettimeofday(@tv,nil)=0; SetDatetime:=fpSettimeofday(@tv,nil)=0;
end; end;
Procedure GetTime(Var Hour, Minute, Second, Sec100: Word); Procedure GetTime(Var Hour, Minute, Second, Sec100: Word);
var var
tz:timeval; tz:timeval;
@ -279,23 +275,6 @@ begin
sec100:=tz.tv_usec div 10000; sec100:=tz.tv_usec div 10000;
end; end;
Procedure packtime(var t : datetime;var p : longint);
Begin
p:=(t.sec shr 1)+(t.min shl 5)+(t.hour shl 11)+(t.day shl 16)+(t.month shl 21)+((t.year-1980) shl 25);
End;
Procedure unpacktime(p : longint;var t : datetime);
Begin
t.sec:=(p and 31) shl 1;
t.min:=(p shr 5) and 63;
t.hour:=(p shr 11) and 31;
t.day:=(p shr 16) and 31;
t.month:=(p shr 21) and 15;
t.year:=(p shr 25)+1980;
End;
Procedure UnixDateToDt(SecsPast: LongInt; Var Dt: DateTime); Procedure UnixDateToDt(SecsPast: LongInt; Var Dt: DateTime);
Begin Begin
@ -303,52 +282,26 @@ Begin
End; End;
Function DTToUnixDate(DT: DateTime): LongInt; Function DTToUnixDate(DT: DateTime): LongInt;
Begin Begin
DTToUnixDate:=LocalToEpoch(dt.Year,dt.Month,dt.Day,dt.Hour,dt.Min,dt.Sec); DTToUnixDate:=LocalToEpoch(dt.Year,dt.Month,dt.Day,dt.Hour,dt.Min,dt.Sec);
End; End;
function GetMsCount: int64;
var
tv : TimeVal;
{ tz : TimeZone;}
begin
FPGetTimeOfDay (@tv, nil {,tz});
GetMsCount := tv.tv_Sec * 1000 + tv.tv_uSec div 1000;
end;
{****************************************************************************** {******************************************************************************
--- Exec --- --- Exec ---
******************************************************************************} ******************************************************************************}
Procedure FSplit( Path:PathStr;Var Dir:DirStr;Var Name:NameStr;Var Ext:ExtStr);
Var
DotPos,SlashPos,i : longint;
Begin
SlashPos:=0;
DotPos:=256;
i:=Length(Path);
While (i>0) and (SlashPos=0) Do
Begin
If (DotPos=256) and (Path[i]='.') Then
begin
DotPos:=i;
end;
If (Path[i]='/') Then
SlashPos:=i;
Dec(i);
End;
Ext:=Copy(Path,DotPos,255);
Dir:=Copy(Path,1,SlashPos);
Name:=Copy(Path,SlashPos + 1,DotPos - SlashPos - 1);
End;
{$ifdef HASTHREADVAR}
{$ifdef VER1_9_2}
var
{$else VER1_9_2}
threadvar
{$endif VER1_9_2}
{$else HASTHREADVAR}
var
{$endif HASTHREADVAR}
LastDosExitCode: word;
Procedure Exec (Const Path: PathStr; Const ComLine: ComStr); Procedure Exec (Const Path: PathStr; Const ComLine: ComStr);
var var
pid : longint; // pid_t? pid : longint; // pid_t?
@ -396,13 +349,6 @@ Begin
End; End;
Function DosExitCode: Word;
Begin
DosExitCode:=LastDosExitCode;
End;
{****************************************************************************** {******************************************************************************
--- Disk --- --- Disk ---
******************************************************************************} ******************************************************************************}
@ -797,17 +743,6 @@ End;
--- File --- --- File ---
******************************************************************************} ******************************************************************************}
{$DEFINE FPC_FEXPAND_TILDE} { Tilde is expanded to home }
{$DEFINE FPC_FEXPAND_GETENVPCHAR} { GetEnv result is a PChar }
{$I fexpand.inc}
{$UNDEF FPC_FEXPAND_GETENVPCHAR}
{$UNDEF FPC_FEXPAND_TILDE}
Function FSearch(path : pathstr;dirlist : string) : pathstr; Function FSearch(path : pathstr;dirlist : string) : pathstr;
Var Var
info : BaseUnix.stat; info : BaseUnix.stat;
@ -936,54 +871,6 @@ Begin
End; End;
{******************************************************************************
--- Do Nothing Procedures/Functions ---
******************************************************************************}
{$ifdef cpui386}
Procedure Intr (intno: byte; var regs: registers);
Begin
{! No Unix equivalent !}
End;
Procedure msdos(var regs : registers);
Begin
{! No Unix equivalent !}
End;
{$endif cpui386}
Procedure getintvec(intno : byte;var vector : pointer);
Begin
{! No Unix equivalent !}
End;
Procedure setintvec(intno : byte;vector : pointer);
Begin
{! No Unix equivalent !}
End;
Procedure SwapVectors;
Begin
{! No Unix equivalent !}
End;
Procedure keep(exitcode : word);
Begin
{! No Unix equivalent !}
End;
Procedure setfattr (var f;attr : word); Procedure setfattr (var f;attr : word);
Begin Begin
{! No Unix equivalent !} {! No Unix equivalent !}
@ -994,49 +881,6 @@ End;
Procedure GetCBreak(Var BreakValue: Boolean);
Begin
{! No Unix equivalent !}
breakvalue:=true
End;
Procedure SetCBreak(BreakValue: Boolean);
Begin
{! No Unix equivalent !}
End;
Procedure GetVerify(Var Verify: Boolean);
Begin
{! No Unix equivalent !}
Verify:=true;
End;
Procedure SetVerify(Verify: Boolean);
Begin
{! No Unix equivalent !}
End;
function GetShortName(var p : String) : boolean;
begin
{ short=long under *nix}
GetShortName:=True;
end;
function GetLongName(var p : String) : boolean;
begin
{ short=long under *nix}
GetLongName:=True;
end;
{****************************************************************************** {******************************************************************************
--- Initialization --- --- Initialization ---
******************************************************************************} ******************************************************************************}
@ -1045,7 +889,10 @@ End.
{ {
$Log$ $Log$
Revision 1.39 2004-12-02 18:24:35 marco Revision 1.40 2004-12-05 16:44:43 hajny
* GetMsCount added, platform independent routines moved to single include file
Revision 1.39 2004/12/02 18:24:35 marco
* fpsettimeofday. * fpsettimeofday.
Revision 1.38 2004/10/31 17:11:52 marco Revision 1.38 2004/10/31 17:11:52 marco

162
rtl/watcom/dos.pp
View File

@ -20,9 +20,6 @@ Uses
Watcom; Watcom;
Const
FileNameLen = 255;
Type Type
searchrec = packed record searchrec = packed record
fill : array[1..21] of byte; fill : array[1..21] of byte;
@ -33,6 +30,7 @@ Type
name : string[255]; { LFN Name, DJGPP uses only [12] but more can't hurt (PFV) } name : string[255]; { LFN Name, DJGPP uses only [12] but more can't hurt (PFV) }
end; end;
{$DEFINE HAS_REGISTERS}
Registers = Watcom.Registers; Registers = Watcom.Registers;
{$i dosh.inc} {$i dosh.inc}
@ -42,6 +40,22 @@ implementation
uses uses
strings; strings;
{$DEFINE HAS_GETMSCOUNT}
{$DEFINE HAS_INTR}
{$DEFINE HAS_GETCBREAK}
{$DEFINE HAS_SETCBREAK}
{$DEFINE HAS_GETVERIFY}
{$DEFINE HAS_SETVERIFY}
{$DEFINE HAS_GETSHORTNAME}
{$DEFINE HAS_GETLONGNAME}
{$DEFINE HAS_GETMSCOUNT}
{$DEFINE FPC_FEXPAND_UNC} (* UNC paths are supported *)
{$DEFINE FPC_FEXPAND_DRIVES} (* Full paths begin with drive specification *)
{$I dos.inc}
{****************************************************************************** {******************************************************************************
--- Dos Interrupt --- --- Dos Interrupt ---
******************************************************************************} ******************************************************************************}
@ -82,12 +96,6 @@ begin
end; end;
procedure msdos(var regs : registers);
begin
intr($21,regs);
end;
{****************************************************************************** {******************************************************************************
--- Info / Date / Time --- --- Info / Date / Time ---
******************************************************************************} ******************************************************************************}
@ -142,38 +150,15 @@ begin
msdos(dosregs); msdos(dosregs);
end; end;
function GetMsCount: int64;
Procedure packtime(var t : datetime;var p : longint);
Begin
p:=(t.sec shr 1)+(t.min shl 5)+(t.hour shl 11)+(t.day shl 16)+(t.month shl 21)+((t.year-1980) shl 25);
End;
Procedure unpacktime(p : longint;var t : datetime);
Begin
with t do
begin begin
sec:=(p and 31) shl 1; GetMsCount := MemL [$40:$6c] * 55;
min:=(p shr 5) and 63;
hour:=(p shr 11) and 31;
day:=(p shr 16) and 31;
month:=(p shr 21) and 15;
year:=(p shr 25)+1980;
end; end;
End;
{****************************************************************************** {******************************************************************************
--- Exec --- --- Exec ---
******************************************************************************} ******************************************************************************}
{$ifdef HASTHREADVAR}
threadvar
{$else HASTHREADVAR}
var
{$endif HASTHREADVAR}
lastdosexitcode : word;
procedure exec(const path : pathstr;const comline : comstr); procedure exec(const path : pathstr;const comline : comstr);
type type
realptr = packed record realptr = packed record
@ -296,12 +281,6 @@ begin
end; end;
function dosexitcode : word;
begin
dosexitcode:=lastdosexitcode;
end;
procedure getcbreak(var breakvalue : boolean); procedure getcbreak(var breakvalue : boolean);
begin begin
dosregs.ax:=$3300; dosregs.ax:=$3300;
@ -618,7 +597,7 @@ begin
end; end;
type swap_proc = procedure; //type swap_proc = procedure;
//var //var
// _swap_in : swap_proc;external name '_swap_in'; // _swap_in : swap_proc;external name '_swap_in';
@ -626,93 +605,22 @@ type swap_proc = procedure;
// _exception_exit : pointer;external name '_exception_exit'; // _exception_exit : pointer;external name '_exception_exit';
// _v2prt0_exceptions_on : longbool;external name '_v2prt0_exceptions_on'; // _v2prt0_exceptions_on : longbool;external name '_v2prt0_exceptions_on';
(*
procedure swapvectors; procedure swapvectors;
begin begin
(* if _exception_exit<>nil then if _exception_exit<>nil then
if _v2prt0_exceptions_on then if _v2prt0_exceptions_on then
_swap_out() _swap_out()
else else
_swap_in();*) _swap_in();
end; end;
*)
{****************************************************************************** {******************************************************************************
--- File --- --- File ---
******************************************************************************} ******************************************************************************}
procedure fsplit(path : pathstr;var dir : dirstr;var name : namestr;var ext : extstr);
var
dotpos,p1,i : longint;
begin
{ allow slash as backslash }
for i:=1 to length(path) do
if path[i]='/' then path[i]:='\';
{ get drive name }
p1:=pos(':',path);
if p1>0 then
begin
dir:=path[1]+':';
delete(path,1,p1);
end
else
dir:='';
{ split the path and the name, there are no more path informtions }
{ if path contains no backslashes }
while true do
begin
p1:=pos('\',path);
if p1=0 then
break;
dir:=dir+copy(path,1,p1);
delete(path,1,p1);
end;
{ try to find out a extension }
if LFNSupport then
begin
Ext:='';
i:=Length(Path);
DotPos:=256;
While (i>0) Do
Begin
If (Path[i]='.') Then
begin
DotPos:=i;
break;
end;
Dec(i);
end;
Ext:=Copy(Path,DotPos,255);
Name:=Copy(Path,1,DotPos - 1);
end
else
begin
p1:=pos('.',path);
if p1>0 then
begin
ext:=copy(path,p1,4);
delete(path,p1,length(path)-p1+1);
end
else
ext:='';
name:=path;
end;
end;
(*
function FExpand (const Path: PathStr): PathStr;
- declared in fexpand.inc
*)
{$DEFINE FPC_FEXPAND_UNC} (* UNC paths are supported *)
{$DEFINE FPC_FEXPAND_DRIVES} (* Full paths begin with drive specification *)
{$I fexpand.inc}
{$UNDEF FPC_FEXPAND_DRIVES}
{$UNDEF FPC_FEXPAND_UNC}
Function FSearch(path: pathstr; dirlist: string): pathstr; Function FSearch(path: pathstr; dirlist: string): pathstr;
var var
i,p1 : longint; i,p1 : longint;
@ -930,28 +838,14 @@ begin
end; end;
{******************************************************************************
--- Not Supported ---
******************************************************************************}
Procedure keep(exitcode : word);
Begin
End;
Procedure getintvec(intno : byte;var vector : pointer);
Begin
End;
Procedure setintvec(intno : byte;vector : pointer);
Begin
End;
end. end.
{ {
$Log$ $Log$
Revision 1.8 2004-02-17 17:37:26 daniel Revision 1.9 2004-12-05 16:44:43 hajny
* GetMsCount added, platform independent routines moved to single include file
Revision 1.8 2004/02/17 17:37:26 daniel
* Enable threadvars again * Enable threadvars again
Revision 1.7 2004/02/16 22:18:44 hajny Revision 1.7 2004/02/16 22:18:44 hajny

184
rtl/win32/dos.pp
View File

@ -1,7 +1,7 @@
{ {
$Id$ $Id$
This file is part of the Free Pascal run time library. This file is part of the Free Pascal run time library.
Copyright (c) 1999-2000 by the Free Pascal development team. Copyright (c) 1999-2004 by the Free Pascal development team.
Dos unit for BP7 compatible RTL Dos unit for BP7 compatible RTL
@ -18,7 +18,6 @@ interface
Const Const
Max_Path = 260; Max_Path = 260;
FileNameLen = 255;
Type Type
TWin32Handle = longint; TWin32Handle = longint;
@ -55,18 +54,8 @@ Type
name : string; name : string;
end; end;
registers = packed record
case i : integer of
0 : (ax,f1,bx,f2,cx,f3,dx,f4,bp,f5,si,f51,di,f6,ds,f7,es,f8,flags,fs,gs : word);
1 : (al,ah,f9,f10,bl,bh,f11,f12,cl,ch,f13,f14,dl,dh : byte);
2 : (eax, ebx, ecx, edx, ebp, esi, edi : longint);
end;
{$i dosh.inc} {$i dosh.inc}
Const Const
{ allow EXEC to inherited handles from calling process, { allow EXEC to inherited handles from calling process,
needed for FPREDIR in ide/text needed for FPREDIR in ide/text
@ -81,6 +70,15 @@ implementation
uses uses
strings; strings;
{$DEFINE HAS_GETMSCOUNT}
{$DEFINE HAS_GETSHORTNAME}
{$DEFINE HAS_GETLONGNAME}
{$DEFINE FPC_FEXPAND_UNC} (* UNC paths are supported *)
{$DEFINE FPC_FEXPAND_DRIVES} (* Full paths begin with drive specification *)
{$I dos.inc}
const const
INVALID_HANDLE_VALUE = longint($ffffffff); INVALID_HANDLE_VALUE = longint($ffffffff);
@ -116,6 +114,13 @@ var
stdcall; external 'kernel32' name 'FileTimeToLocalFileTime'; stdcall; external 'kernel32' name 'FileTimeToLocalFileTime';
function LocalFileTimeToFileTime(const lft : TWin32FileTime;var ft : TWin32FileTime) : longbool; function LocalFileTimeToFileTime(const lft : TWin32FileTime;var ft : TWin32FileTime) : longbool;
stdcall; external 'kernel32' name 'LocalFileTimeToFileTime'; stdcall; external 'kernel32' name 'LocalFileTimeToFileTime';
function GetTickCount : longint;
stdcall;external 'kernel32' name 'GetTickCount';
function GetMsCount: int64;
begin
GetMsCount := cardinal (GetTickCount);
end;
type type
Longrec=packed record Longrec=packed record
@ -163,21 +168,6 @@ begin
end; end;
{******************************************************************************
--- Dos Interrupt ---
******************************************************************************}
procedure intr(intno : byte;var regs : registers);
begin
{ !!!!!!!! }
end;
procedure msdos(var regs : registers);
begin
{ !!!!!!!! }
end;
{****************************************************************************** {******************************************************************************
--- Info / Date / Time --- --- Info / Date / Time ---
******************************************************************************} ******************************************************************************}
@ -263,26 +253,6 @@ begin
end; end;
Procedure packtime(var t : datetime;var p : longint);
Begin
p:=(t.sec shr 1)+(t.min shl 5)+(t.hour shl 11)+(t.day shl 16)+(t.month shl 21)+((t.year-1980) shl 25);
End;
Procedure unpacktime(p : longint;var t : datetime);
Begin
with t do
begin
sec:=(p and 31) shl 1;
min:=(p shr 5) and 63;
hour:=(p shr 11) and 31;
day:=(p shr 16) and 31;
month:=(p shr 21) and 15;
year:=(p shr 25)+1980;
end;
End;
{****************************************************************************** {******************************************************************************
--- Exec --- --- Exec ---
******************************************************************************} ******************************************************************************}
@ -309,13 +279,6 @@ type
function CloseHandle(h : TWin32Handle) : longint; function CloseHandle(h : TWin32Handle) : longint;
stdcall; external 'kernel32' name 'CloseHandle'; stdcall; external 'kernel32' name 'CloseHandle';
{$ifdef HASTHREADVAR}
threadvar
{$else HASTHREADVAR}
var
{$endif HASTHREADVAR}
lastdosexitcode : longint;
procedure exec(const path : pathstr;const comline : comstr); procedure exec(const path : pathstr;const comline : comstr);
var var
SI: TStartupInfo; SI: TStartupInfo;
@ -364,38 +327,6 @@ begin
end; end;
function dosexitcode : word;
begin
dosexitcode:=lastdosexitcode and $ffff;
end;
procedure getcbreak(var breakvalue : boolean);
begin
{ !! No Win32 Function !! }
breakvalue := true;
end;
procedure setcbreak(breakvalue : boolean);
begin
{ !! No Win32 Function !! }
end;
procedure getverify(var verify : boolean);
begin
{ !! No Win32 Function !! }
verify := true;
end;
procedure setverify(verify : boolean);
begin
{ !! No Win32 Function !! }
end;
{****************************************************************************** {******************************************************************************
--- Disk --- --- Disk ---
******************************************************************************} ******************************************************************************}
@ -579,11 +510,6 @@ begin
end; end;
procedure swapvectors;
begin
end;
Procedure FindClose(Var f: SearchRec); Procedure FindClose(Var f: SearchRec);
begin begin
If longint(F.FindHandle)<>Invalid_Handle_value then If longint(F.FindHandle)<>Invalid_Handle_value then
@ -604,48 +530,6 @@ end;
function GetFileAttributes(lpFileName : pchar) : longint; function GetFileAttributes(lpFileName : pchar) : longint;
stdcall; external 'kernel32' name 'GetFileAttributesA'; stdcall; external 'kernel32' name 'GetFileAttributesA';
procedure fsplit(path : pathstr;var dir : dirstr;var name : namestr;var ext : extstr);
var
dotpos,p1,i : longint;
begin
{ allow slash as backslash }
for i:=1 to length(path) do
if path[i]='/' then path[i]:='\';
{ get drive name }
p1:=pos(':',path);
if p1>0 then
begin
dir:=path[1]+':';
delete(path,1,p1);
end
else
dir:='';
{ split the path and the name, there are no more path informtions }
{ if path contains no backslashes }
while true do
begin
p1:=pos('\',path);
if p1=0 then
break;
dir:=dir+copy(path,1,p1);
delete(path,1,p1);
end;
{ try to find out a extension }
Ext:='';
i:=Length(Path);
DotPos:=256;
While (i>0) Do
Begin
If (Path[i]='.') Then
begin
DotPos:=i;
break;
end;
Dec(i);
end;
Ext:=Copy(Path,DotPos,255);
Name:=Copy(Path,1,DotPos - 1);
end;
{ <immobilizer> } { <immobilizer> }
@ -656,19 +540,6 @@ function GetShortPathName(lpszLongPath:pchar; lpszShortPath:pchar; cchBuffer:DWO
stdcall; external 'kernel32' name 'GetShortPathNameA'; stdcall; external 'kernel32' name 'GetShortPathNameA';
(*
function FExpand (const Path: PathStr): PathStr;
- declared in fexpand.inc
*)
{$DEFINE FPC_FEXPAND_UNC} (* UNC paths are supported *)
{$DEFINE FPC_FEXPAND_DRIVES} (* Full paths begin with drive specification *)
{$I fexpand.inc}
{$UNDEF FPC_FEXPAND_DRIVES}
{$UNDEF FPC_FEXPAND_UNC}
Function FSearch(path: pathstr; dirlist: string): pathstr; Function FSearch(path: pathstr; dirlist: string): pathstr;
var var
i,p1 : longint; i,p1 : longint;
@ -905,22 +776,6 @@ begin
end; end;
{******************************************************************************
--- Not Supported ---
******************************************************************************}
Procedure keep(exitcode : word);
Begin
End;
Procedure getintvec(intno : byte;var vector : pointer);
Begin
End;
Procedure setintvec(intno : byte;vector : pointer);
Begin
End;
function FreeLibrary(hLibModule : TWin32Handle) : longbool; function FreeLibrary(hLibModule : TWin32Handle) : longbool;
stdcall; external 'kernel32' name 'FreeLibrary'; stdcall; external 'kernel32' name 'FreeLibrary';
function GetVersionEx(var VersionInformation:OSVERSIONINFO) : longbool; function GetVersionEx(var VersionInformation:OSVERSIONINFO) : longbool;
@ -959,7 +814,10 @@ begin
end. end.
{ {
$Log$ $Log$
Revision 1.28 2004-04-07 09:26:23 michael Revision 1.29 2004-12-05 16:44:43 hajny
* GetMsCount added, platform independent routines moved to single include file
Revision 1.28 2004/04/07 09:26:23 michael
+ Patch for findfirst (bug 3042) from Peter Vreman + Patch for findfirst (bug 3042) from Peter Vreman
Revision 1.27 2004/03/14 18:43:21 peter Revision 1.27 2004/03/14 18:43:21 peter