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

* added (limited) GetLastOSError by emulation of Win32 and *nix behaviour in the RTL

Browse Source 
git-svn-id: trunk@28947 -
This commit is contained in:
Tomas Hajny 2014-10-30 14:44:03 +00:00
parent 3296c3d381
commit 8cd2b615ce
10 changed files with 836 additions and 313 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

134
rtl/os2/dos.pas
View File

@ -113,6 +113,8 @@ begin
P:=Path; P:=Path;
D:=DirList; D:=DirList;
DosError := DosSearchPath (dsIgnoreNetErrs, PChar(D), PChar(P), @A, 255); DosError := DosSearchPath (dsIgnoreNetErrs, PChar(D), PChar(P), @A, 255);
if DosError <> 0 then
OSErrorWatch (DosError);
fsearch := StrPas (@A); fsearch := StrPas (@A);
end; end;
@ -124,12 +126,16 @@ begin
DosError := DosQueryFileInfo (FileRec (F).Handle, ilStandard, @FStat, DosError := DosQueryFileInfo (FileRec (F).Handle, ilStandard, @FStat,
SizeOf (FStat)); SizeOf (FStat));
if DosError=0 then if DosError=0 then
begin begin
Time := FStat.TimeLastWrite + longint (FStat.DateLastWrite) shl 16; Time := FStat.TimeLastWrite + longint (FStat.DateLastWrite) shl 16;
if Time = 0 then if Time = 0 then
Time := FStat.TimeCreation + longint (FStat.DateCreation) shl 16; Time := FStat.TimeCreation + longint (FStat.DateCreation) shl 16;
end else end
else
begin
Time:=0; Time:=0;
OSErrorWatch (DosError);
end;
end; end;
@ -140,14 +146,18 @@ begin
RC := DosQueryFileInfo (FileRec (F).Handle, ilStandard, @FStat, RC := DosQueryFileInfo (FileRec (F).Handle, ilStandard, @FStat,
SizeOf (FStat)); SizeOf (FStat));
if RC = 0 then if RC = 0 then
begin begin
FStat.DateLastAccess := Hi (Time); FStat.DateLastAccess := Hi (Time);
FStat.DateLastWrite := Hi (Time); FStat.DateLastWrite := Hi (Time);
FStat.TimeLastAccess := Lo (Time); FStat.TimeLastAccess := Lo (Time);
FStat.TimeLastWrite := Lo (Time); FStat.TimeLastWrite := Lo (Time);
RC := DosSetFileInfo (FileRec (F).Handle, ilStandard, @FStat, RC := DosSetFileInfo (FileRec (F).Handle, ilStandard, @FStat,
SizeOf (FStat)); SizeOf (FStat));
end; if RC <> 0 then
OSErrorWatch (RC);
end
else
OSErrorWatch (RC);
DosError := integer (RC); DosError := integer (RC);
end; end;
@ -170,7 +180,10 @@ begin
LastExecRes := Res; LastExecRes := Res;
end end
else else
LastExecRes.ExitCode := RC shl 16; begin
LastExecRes.ExitCode := RC shl 16;
OSErrorWatch (RC);
end;
end; end;
if LastExecRes.ExitCode > high (word) then if LastExecRes.ExitCode > high (word) then
DosExitCode := high (word) DosExitCode := high (word)
@ -186,7 +199,7 @@ var
ArgSize: word; ArgSize: word;
ObjName: string; ObjName: string;
Res: TResultCodes; Res: TResultCodes;
RC: cardinal; RC, RC2: cardinal;
ExecAppType: cardinal; ExecAppType: cardinal;
HQ: THandle; HQ: THandle;
SPID, STID, SCtr, QName: string; SPID, STID, SCtr, QName: string;
@ -239,22 +252,28 @@ begin
Args^ [ArgSize] := 0; Args^ [ArgSize] := 0;
end; end;
if (DosQueryAppType (PChar (Args), ExecAppType) = 0) and RC := DosQueryAppType (PChar (Args), ExecAppType);
(ApplicationType and 3 = ExecAppType and 3) then if RC <> 0 then
OSErrorWatch (RC)
else
if (ApplicationType and 3 = ExecAppType and 3) then
(* DosExecPgm should work... *) (* DosExecPgm should work... *)
begin begin
DSS := false; DSS := false;
Res.ExitCode := $FFFFFFFF; Res.ExitCode := $FFFFFFFF;
RC := DosExecPgm (ObjName, cardinal (ExecFlags), Args, nil, Res, Path); RC := DosExecPgm (ObjName, cardinal (ExecFlags), Args, nil, Res, Path);
if RC = 0 then if RC = 0 then
begin begin
LastExecFlags := ExecFlags; LastExecFlags := ExecFlags;
LastExecRes := Res; LastExecRes := Res;
LastDosErrorModuleName := ''; LastDosErrorModuleName := '';
end end
else else
if (RC = 190) or (RC = 191) then begin
DSS := true; if (RC = 190) or (RC = 191) then
DSS := true;
OSErrorWatch (RC);
end;
end end
else else
DSS := true; DSS := true;
@ -273,6 +292,8 @@ begin
LastExecFlags := ExecFlags; LastExecFlags := ExecFlags;
SD.TermQ := @QName [1]; SD.TermQ := @QName [1];
RC := DosCreateQueue (HQ, quFIFO or quConvert_Address, @QName [1]); RC := DosCreateQueue (HQ, quFIFO or quConvert_Address, @QName [1]);
if RC <> 0 then
OSErrorWatch (RC);
end; end;
deAsync, deAsync,
deAsyncResult: deAsyncResult:
@ -318,24 +339,40 @@ begin
SD.ObjectBuffer := @ObjName [1]; SD.ObjectBuffer := @ObjName [1];
SD.ObjectBuffLen := SizeOf (ObjName) - 1; SD.ObjectBuffLen := SizeOf (ObjName) - 1;
RC := DosStartSession (SD, SID, PID); RC := DosStartSession (SD, SID, PID);
if RC <> 0 then
OSErrorWatch (RC);
if (RC = 0) or (RC = 457) then if (RC = 0) or (RC = 457) then
begin begin
LastExecRes.PID := PID; LastExecRes.PID := PID;
if ExecFlags = deSync then if ExecFlags = deSync then
begin begin
RC := DosReadQueue (HQ, RD, CISize, PCI, 0, 0, Prio, 0); RC := DosReadQueue (HQ, RD, CISize, PCI, 0, 0, Prio, 0);
if RC <> 0 then
OSErrorWatch (RC);
if (RC = 0) and (PCI^.SessionID = SID) then if (RC = 0) and (PCI^.SessionID = SID) then
begin begin
LastExecRes.ExitCode := PCI^.Return; LastExecRes.ExitCode := PCI^.Return;
DosCloseQueue (HQ); RC2 := DosCloseQueue (HQ);
DosFreeMem (PCI); if RC2 <> 0 then
OSErrorWatch (RC2);
RC2 := DosFreeMem (PCI);
if RC2 <> 0 then
OSErrorWatch (RC2);
end end
else else
DosCloseQueue (HQ); begin
RC2 := DosCloseQueue (HQ);
if RC2 <> 0 then
OSErrorWatch (RC2);
end;
end; end;
end end
else if ExecFlags = deSync then else if ExecFlags = deSync then
DosCloseQueue (HQ); begin
RC2 := DosCloseQueue (HQ);
if RC2 <> 0 then
OSErrorWatch (RC2);
end;
end; end;
end; end;
if RC <> 0 then if RC <> 0 then
@ -383,12 +420,15 @@ end;
procedure SetDate (Year, Month, Day: word); procedure SetDate (Year, Month, Day: word);
var var
DT: TDateTime; DT: TDateTime;
RC: cardinal;
begin begin
DosGetDateTime (DT); DosGetDateTime (DT);
DT.Year := Year; DT.Year := Year;
DT.Month := byte (Month); DT.Month := byte (Month);
DT.Day := byte (Day); DT.Day := byte (Day);
DosSetDateTime (DT); RC := DosSetDateTime (DT);
if RC <> 0 then
OSErrorWatch (RC);
end; end;
@ -407,6 +447,7 @@ end;
procedure SetTime (Hour, Minute, Second, Sec100: word); procedure SetTime (Hour, Minute, Second, Sec100: word);
var var
DT: TDateTime; DT: TDateTime;
RC: cardinal;
begin begin
DosGetDateTime (DT); DosGetDateTime (DT);
DT.Hour := byte (Hour); DT.Hour := byte (Hour);
@ -414,6 +455,8 @@ begin
DT.Second := byte (Second); DT.Second := byte (Second);
DT.Sec100 := byte (Sec100); DT.Sec100 := byte (Sec100);
DosSetDateTime (DT); DosSetDateTime (DT);
if RC <> 0 then
OSErrorWatch (RC);
end; end;
function DiskFree (Drive: byte): int64; function DiskFree (Drive: byte): int64;
@ -426,7 +469,10 @@ begin
DiskFree := int64 (FI.Free_Clusters) * DiskFree := int64 (FI.Free_Clusters) *
int64 (FI.Sectors_Per_Cluster) * int64 (FI.Bytes_Per_Sector) int64 (FI.Sectors_Per_Cluster) * int64 (FI.Bytes_Per_Sector)
else else
DiskFree := -1; begin
DiskFree := -1;
OSErrorWatch (RC);
end;
end; end;
@ -439,7 +485,10 @@ begin
DiskSize := int64 (FI.Total_Clusters) * DiskSize := int64 (FI.Total_Clusters) *
int64 (FI.Sectors_Per_Cluster) * int64 (FI.Bytes_Per_Sector) int64 (FI.Sectors_Per_Cluster) * int64 (FI.Bytes_Per_Sector)
else else
DiskSize := -1; begin
DiskSize := -1;
OSErrorWatch (RC);
end;
end; end;
@ -474,7 +523,10 @@ begin
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^),
Count, ilStandard)); Count, ilStandard));
if (DosError = 0) and (Count = 0) then DosError := 18; if DosError <> 0 then
OSErrorWatch (DosError)
else if Count = 0 then
DosError := 18;
DosSearchRec2SearchRec (F); DosSearchRec2SearchRec (F);
end; end;
@ -488,14 +540,22 @@ begin
Count := 1; Count := 1;
DosError := integer (DosFindNext (F.Handle, F.FStat, SizeOf (F.FStat^), DosError := integer (DosFindNext (F.Handle, F.FStat, SizeOf (F.FStat^),
Count)); Count));
if (DosError = 0) and (Count = 0) then DosError := 18; if DosError <> 0 then
OSErrorWatch (DosError)
else if Count = 0 then
DosError := 18;
DosSearchRec2SearchRec (F); DosSearchRec2SearchRec (F);
end; end;
procedure FindClose (var F: SearchRec); procedure FindClose (var F: SearchRec);
begin begin
if F.Handle <> THandle ($FFFFFFFF) then DosError := DosFindClose (F.Handle); if F.Handle <> THandle ($FFFFFFFF) then
begin
DosError := integer (DosFindClose (F.Handle));
if DosError <> 0 then
OSErrorWatch (DosError);
end;
Dispose (F.FStat); Dispose (F.FStat);
end; end;
@ -607,7 +667,9 @@ begin
RC := DosQueryPathInfo (P, ilStandard, @PathInfo, SizeOf (PathInfo)); RC := DosQueryPathInfo (P, ilStandard, @PathInfo, SizeOf (PathInfo));
DosError := integer (RC); DosError := integer (RC);
if RC = 0 then if RC = 0 then
Attr := PathInfo.AttrFile; Attr := PathInfo.AttrFile
else
OSErrorWatch (RC);
end; end;
@ -628,11 +690,15 @@ begin
{$endif FPC_ANSI_TEXTFILEREC} {$endif FPC_ANSI_TEXTFILEREC}
RC := DosQueryPathInfo (P, ilStandard, @PathInfo, SizeOf (PathInfo)); RC := DosQueryPathInfo (P, ilStandard, @PathInfo, SizeOf (PathInfo));
if RC = 0 then if RC = 0 then
begin begin
PathInfo.AttrFile := Attr; PathInfo.AttrFile := Attr;
RC := DosSetPathInfo (P, ilStandard, @PathInfo, SizeOf (PathInfo), RC := DosSetPathInfo (P, ilStandard, @PathInfo, SizeOf (PathInfo),
doWriteThru); doWriteThru);
end; if RC <> 0 then
OSErrorWatch (RC);
end
else
OSErrorWatch (RC);
DosError := integer (RC); DosError := integer (RC);
end; end;

33
rtl/os2/dynlibs.inc
View File

@ -54,7 +54,10 @@ begin
if DynLibErrNo = 0 then if DynLibErrNo = 0 then
Result := Handle Result := Handle
else else
Result := NilHandle; begin
Result := NilHandle;
OSErrorWatch (DynLibErrNo);
end;
end; end;
function GetProcedureAddress (Lib: TLibHandle; const ProcName: AnsiString): pointer; function GetProcedureAddress (Lib: TLibHandle; const ProcName: AnsiString): pointer;
@ -66,7 +69,10 @@ begin
if DynLibErrNo = 0 then if DynLibErrNo = 0 then
Result := P Result := P
else else
Result := nil; begin
Result := nil;
OSErrorWatch (DynLibErrNo);
end;
end; end;
function GetProcedureAddress (Lib: TLibHandle; Ordinal: TOrdinalEntry): pointer; function GetProcedureAddress (Lib: TLibHandle; Ordinal: TOrdinalEntry): pointer;
@ -78,7 +84,10 @@ begin
if DynLibErrNo = 0 then if DynLibErrNo = 0 then
Result := P Result := P
else else
Result := nil; begin
Result := nil;
OSErrorWatch (DynLibErrNo);
end;
end; end;
function UnloadLibrary (Lib: TLibHandle): boolean; function UnloadLibrary (Lib: TLibHandle): boolean;
@ -86,6 +95,8 @@ begin
DynLibErrPath [0] := #0; DynLibErrPath [0] := #0;
DynLibErrNo := DosFreeModule (Lib); DynLibErrNo := DosFreeModule (Lib);
Result := DynLibErrNo = 0; Result := DynLibErrNo = 0;
if DynLibErrNo <> 0 then
OSErrorWatch (DynLibErrNo);
end; end;
function GetDynLibsError: longint; function GetDynLibsError: longint;
@ -102,22 +113,26 @@ var
RetMsgSize: cardinal; RetMsgSize: cardinal;
RC: cardinal; RC: cardinal;
begin begin
if DynLibErrNo = 0 then GetDynLibsErrorStr := '';
GetDynLibsErrorStr := '' if DynLibErrNo <> 0 then
else
begin begin
Result := '';
VarArr [1] := @DynLibErrPath [0]; VarArr [1] := @DynLibErrPath [0];
RC := DosGetMessage (@VarArr, 1, @OutBuf [0], SizeOf (OutBuf), RC := DosGetMessage (@VarArr, 1, @OutBuf [0], SizeOf (OutBuf),
DynLibErrNo, @SysMsgFile [0], RetMsgSize); DynLibErrNo, @SysMsgFile [0], RetMsgSize);
if RC = 0 then if RC = 0 then
Result := StrPas (@OutBuf [0]) begin
SetLength (Result, RetMsgSize);
Move (OutBuf [0], Result [1], RetMsgSize);
end
else else
begin begin
Str (DynLibErrNo, Result); Str (DynLibErrNo, Result);
Result := 'Error ' + Result; Result := 'Error ' + Result;
if DynLibErrPath [0] <> #0 then
Result := StrPas (@DynLibErrPath [0]) + ' - ' + Result;
OSErrorWatch (RC);
end; end;
if DynLibErrPath [0] <> #0 then
Result := StrPas (@DynLibErrPath [0]) + ' - ' + Result;
end; end;
end; end;

18
rtl/os2/sysdir.inc
View File

@ -29,6 +29,7 @@ begin
begin begin
InOutRes := Rc; InOutRes := Rc;
Errno2Inoutres; Errno2Inoutres;
OSErrorWatch (RC);
end; end;
end; end;
@ -47,6 +48,7 @@ begin
begin begin
InOutRes := Rc; InOutRes := Rc;
Errno2Inoutres; Errno2Inoutres;
OSErrorWatch (RC);
end; end;
end; end;
@ -63,7 +65,10 @@ begin
begin begin
RC := DosSetDefaultDisk ((Ord (S [1]) and not ($20)) - $40); RC := DosSetDefaultDisk ((Ord (S [1]) and not ($20)) - $40);
if RC <> 0 then if RC <> 0 then
InOutRes := RC begin
InOutRes := RC;
OSErrorWatch (RC);
end
else else
if Len > 2 then if Len > 2 then
begin begin
@ -75,6 +80,7 @@ begin
begin begin
InOutRes := RC; InOutRes := RC;
Errno2InOutRes; Errno2InOutRes;
OSErrorWatch (RC);
end; end;
end; end;
end else begin end else begin
@ -86,6 +92,7 @@ begin
begin begin
InOutRes:= RC; InOutRes:= RC;
Errno2InOutRes; Errno2InOutRes;
OSErrorWatch (RC);
end; end;
end; end;
end; end;
@ -97,6 +104,7 @@ procedure do_GetDir (DriveNr: byte; var Dir: RawByteString);
var sof: Pchar; var sof: Pchar;
i:byte; i:byte;
l,l2:cardinal; l,l2:cardinal;
RC: cardinal;
begin begin
setlength(Dir,255); setlength(Dir,255);
Dir [4] := #0; Dir [4] := #0;
@ -109,7 +117,13 @@ begin
{ TODO: if max path length is > 255, increase the setlength parameter above and { TODO: if max path length is > 255, increase the setlength parameter above and
the 255 below } the 255 below }
l:=255-3; l:=255-3;
InOutRes:=longint (DosQueryCurrentDir(DriveNr, sof^, l)); RC := DosQueryCurrentDir(DriveNr, sof^, l);
if RC <> 0 then
begin
InOutRes := longint (RC);
Errno2Inoutres;
OSErrorWatch (RC);
end;
{$WARNING Result code should be translated in some cases!} {$WARNING Result code should be translated in some cases!}
{ Now Dir should be filled with directory in ASCIIZ, } { Now Dir should be filled with directory in ASCIIZ, }
{ starting from dir[4] } { starting from dir[4] }

146
rtl/os2/sysfile.inc
View File

@ -2,7 +2,7 @@
This file is part of the Free Pascal run time library. This file is part of the Free Pascal run time library.
Copyright (c) 2001 by Free Pascal development team Copyright (c) 2001 by Free Pascal development team
Low leve file functions Low level file functions
See the file COPYING.FPC, included in this distribution, See the file COPYING.FPC, included in this distribution,
for details about the copyright. for details about the copyright.
@ -20,12 +20,19 @@
****************************************************************************} ****************************************************************************}
procedure do_close(h:thandle); procedure do_close(h:thandle);
var
RC: cardinal;
begin begin
{ Only three standard handles under real OS/2 } { Only three standard handles under real OS/2 }
if h>2 then if h>2 then
begin begin
InOutRes:=DosClose(h); RC := DosClose (H);
end; if RC <> 0 then
begin
InOutRes := longint (RC);
OSErrorWatch (RC);
end;
end;
{$ifdef IODEBUG} {$ifdef IODEBUG}
writeln('do_close: handle=', H, ', InOutRes=', InOutRes); writeln('do_close: handle=', H, ', InOutRes=', InOutRes);
{$endif} {$endif}
@ -34,10 +41,16 @@ end;
procedure do_erase(p:Pchar; pchangeable: boolean); procedure do_erase(p:Pchar; pchangeable: boolean);
var var
oldp: pchar; oldp: pchar;
RC: cardinal;
begin begin
oldp:=p; oldp:=p;
DoDirSeparators(p,pchangeable); DoDirSeparators(p,pchangeable);
inoutres:=DosDelete(p); RC := DosDelete (P);
if RC <> 0 then
begin
InOutRes := longint (RC);
OSErrorWatch (RC);
end;
if p<>oldp then if p<>oldp then
freemem(p); freemem(p);
end; end;
@ -45,12 +58,18 @@ end;
procedure do_rename(p1,p2:Pchar; p1changeable, p2changeable: boolean); procedure do_rename(p1,p2:Pchar; p1changeable, p2changeable: boolean);
var var
oldp1, oldp2 : pchar; oldp1, oldp2 : pchar;
RC: cardinal;
begin begin
oldp1:=p1; oldp1:=p1;
oldp2:=p2; oldp2:=p2;
DoDirSeparators(p1,p1changeable); DoDirSeparators(p1,p1changeable);
DoDirSeparators(p2,p2changeable); DoDirSeparators(p2,p2changeable);
inoutres:=DosMove(p1, p2); RC := DosMove (p1, p2);
if RC <> 0 then
begin
InOutRes := longint (RC);
OSErrorWatch (RC);
end;
if p1<>oldp1 then if p1<>oldp1 then
freemem(p1); freemem(p1);
if p2<>oldp2 then if p2<>oldp2 then
@ -60,11 +79,17 @@ end;
function do_read(h:thandle;addr:pointer;len:longint):longint; function do_read(h:thandle;addr:pointer;len:longint):longint;
Var Var
T: cardinal; T: cardinal;
RC: cardinal;
begin begin
{$ifdef IODEBUG} {$ifdef IODEBUG}
write('do_read: handle=', h, ', addr=', ptrint(addr), ', length=', len); write('do_read: handle=', h, ', addr=', ptrint(addr), ', length=', len);
{$endif} {$endif}
InOutRes:=DosRead(H, Addr, Len, T); RC := DosRead(H, Addr, Len, T);
if RC <> 0 then
begin
InOutRes := longint (RC);
OSErrorWatch (RC);
end;
do_read:= longint (T); do_read:= longint (T);
{$ifdef IODEBUG} {$ifdef IODEBUG}
writeln(', actual_len=', t, ', InOutRes=', InOutRes); writeln(', actual_len=', t, ', InOutRes=', InOutRes);
@ -74,11 +99,17 @@ end;
function do_write(h:thandle;addr:pointer;len:longint) : longint; function do_write(h:thandle;addr:pointer;len:longint) : longint;
Var Var
T: cardinal; T: cardinal;
RC: cardinal;
begin begin
{$ifdef IODEBUG} {$ifdef IODEBUG}
write('do_write: handle=', h, ', addr=', ptrint(addr), ', length=', len); write('do_write: handle=', h, ', addr=', ptrint(addr), ', length=', len);
{$endif} {$endif}
InOutRes:=DosWrite(H, Addr, Len, T); RC := DosWrite(H, Addr, Len, T);
if RC <> 0 then
begin
InOutRes := longint (RC);
OSErrorWatch (RC);
end;
do_write:= longint (T); do_write:= longint (T);
{$ifdef IODEBUG} {$ifdef IODEBUG}
writeln(', actual_len=', t, ', InOutRes=', InOutRes); writeln(', actual_len=', t, ', InOutRes=', InOutRes);
@ -88,8 +119,14 @@ end;
function Do_FilePos (Handle: THandle): int64; function Do_FilePos (Handle: THandle): int64;
var var
PosActual: int64; PosActual: int64;
RC: cardinal;
begin begin
InOutRes := Sys_DosSetFilePtrL (Handle, 0, 1, PosActual); RC := Sys_DosSetFilePtrL (Handle, 0, 1, PosActual);
if RC <> 0 then
begin
InOutRes := longint (RC);
OSErrorWatch (RC);
end;
Do_FilePos := PosActual; Do_FilePos := PosActual;
{$ifdef IODEBUG} {$ifdef IODEBUG}
writeln('do_filepos: handle=', Handle, ', actual_pos=', PosActual, ', InOutRes=', InOutRes); writeln('do_filepos: handle=', Handle, ', actual_pos=', PosActual, ', InOutRes=', InOutRes);
@ -99,8 +136,14 @@ end;
procedure Do_Seek (Handle: THandle; Pos: int64); procedure Do_Seek (Handle: THandle; Pos: int64);
var var
PosActual: int64; PosActual: int64;
RC: cardinal;
begin begin
InOutRes:=Sys_DosSetFilePtrL(Handle, Pos, 0 {ZeroBased}, PosActual); RC := Sys_DosSetFilePtrL(Handle, Pos, 0 {ZeroBased}, PosActual);
if RC <> 0 then
begin
InOutRes := longint (RC);
OSErrorWatch (RC);
end;
{$ifdef IODEBUG} {$ifdef IODEBUG}
writeln('do_seek: handle=', Handle, ', pos=', pos, ', actual_pos=', PosActual, ', InOutRes=', InOutRes); writeln('do_seek: handle=', Handle, ', pos=', pos, ', actual_pos=', PosActual, ', InOutRes=', InOutRes);
{$endif} {$endif}
@ -109,9 +152,17 @@ end;
function Do_SeekEnd (Handle: THandle): int64; function Do_SeekEnd (Handle: THandle): int64;
var var
PosActual: int64; PosActual: int64;
RC: cardinal;
begin begin
InOutRes := Sys_DosSetFilePtrL (Handle, 0, 2 {EndBased}, PosActual); RC := Sys_DosSetFilePtrL (Handle, 0, 2 {EndBased}, PosActual);
Do_SeekEnd := PosActual; if RC <> 0 then
begin
InOutRes := longint (RC);
OSErrorWatch (RC);
Do_SeekEnd := -1;
end
else
Do_SeekEnd := PosActual;
{$ifdef IODEBUG} {$ifdef IODEBUG}
writeln('do_seekend: handle=', Handle, ', actual_pos=', PosActual, ', InOutRes=', InOutRes); writeln('do_seekend: handle=', Handle, ', actual_pos=', PosActual, ', InOutRes=', InOutRes);
{$endif} {$endif}
@ -122,14 +173,25 @@ var
AktFilePos: int64; AktFilePos: int64;
begin begin
AktFilePos := Do_FilePos (Handle); AktFilePos := Do_FilePos (Handle);
Do_FileSize := Do_SeekEnd (Handle); if InOutRes = 0 then
Do_Seek (Handle, AktFilePos); begin
Do_FileSize := Do_SeekEnd (Handle);
Do_Seek (Handle, AktFilePos);
end;
end; end;
procedure Do_Truncate (Handle: THandle; Pos: int64); procedure Do_Truncate (Handle: THandle; Pos: int64);
var
RC: cardinal;
begin begin
InOutRes := Sys_DosSetFileSizeL (Handle, Pos); RC := Sys_DosSetFileSizeL (Handle, Pos);
Do_SeekEnd (Handle); if RC <> 0 then
begin
InOutRes := longint (RC);
OSErrorWatch (RC);
end
else
Do_SeekEnd (Handle);
end; end;
@ -140,18 +202,23 @@ function Increase_File_Handle_Count: boolean;
var Err: word; var Err: word;
L1: longint; L1: longint;
L2: cardinal; L2: cardinal;
RC: cardinal;
begin begin
L1 := 10; L1 := 10;
if DosSetRelMaxFH (L1, L2) <> 0 then RC := DosSetRelMaxFH (L1, L2);
Increase_File_Handle_Count := false if RC <> 0 then
begin
Increase_File_Handle_Count := false;
OSErrorWatch (RC);
end
else else
if L2 > FileHandleCount then if L2 > FileHandleCount then
begin begin
FileHandleCount := L2; FileHandleCount := L2;
Increase_File_Handle_Count := true; Increase_File_Handle_Count := true;
end end
else else
Increase_File_Handle_Count := false; Increase_File_Handle_Count := false;
end; end;
procedure do_open(var f;p:pchar;flags:longint; pchangeable: boolean); procedure do_open(var f;p:pchar;flags:longint; pchangeable: boolean);
@ -166,13 +233,13 @@ procedure do_open(var f;p:pchar;flags:longint; pchangeable: boolean);
var var
Action, Attrib, OpenFlags, FM: Cardinal; Action, Attrib, OpenFlags, FM: Cardinal;
oldp : pchar; oldp : pchar;
RC: cardinal;
begin begin
// close first if opened // close first if opened
if ((flags and $10000)=0) then if ((flags and $10000)=0) then
begin begin
case filerec(f).mode of case filerec(f).mode of
fminput,fmoutput,fminout : Do_Close(filerec(f).handle); fminput,fmoutput,fminout : Do_Close (FileRec (F).Handle);
fmclosed:; fmclosed:;
else else
begin begin
@ -228,14 +295,26 @@ begin
DoDirSeparators(p,pchangeable); DoDirSeparators(p,pchangeable);
Attrib:=32 {faArchive}; Attrib:=32 {faArchive};
InOutRes:=Sys_DosOpenL(p, FileRec(F).Handle, Action, 0, Attrib, OpenFlags, FM, nil); RC := Sys_DosOpenL(p, FileRec(F).Handle, Action, 0, Attrib, OpenFlags, FM, nil);
if RC <> 0 then
begin
InOutRes := longint (RC);
OSErrorWatch (RC);
end;
// If too many open files try to set more file handles and open again // If too many open files try to set more file handles and open again
if (InOutRes = 4) then if (InOutRes = 4) then
if Increase_File_Handle_Count then if Increase_File_Handle_Count then
InOutRes:=Sys_DosOpenL(p, FileRec(F).Handle, Action, 0, Attrib, OpenFlags, FM, nil); begin
RC := Sys_DosOpenL(p, FileRec(F).Handle, Action, 0, Attrib, OpenFlags, FM, nil);
If InOutRes<>0 then FileRec(F).Handle:=UnusedHandle; if RC <> 0 then
begin
InOutRes := longint (RC);
OSErrorWatch (RC);
end;
end;
if RC <> 0 then
FileRec(F).Handle:=UnusedHandle;
// If Handle created -> make some things // If Handle created -> make some things
if (FileRec(F).Handle <> UnusedHandle) then if (FileRec(F).Handle <> UnusedHandle) then
@ -261,9 +340,16 @@ end;
function do_isdevice (Handle: THandle): boolean; function do_isdevice (Handle: THandle): boolean;
var var
HT, Attr: cardinal; HT, Attr: cardinal;
RC: cardinal;
begin begin
do_isdevice:=false; do_isdevice:=false;
If DosQueryHType(Handle, HT, Attr)<>0 then exit; RC := DosQueryHType(Handle, HT, Attr);
if ht=1 then do_isdevice:=true; if RC <> 0 then
begin
OSErrorWatch (RC);
Exit;
end;
if ht=1 then
do_isdevice:=true;
end; end;
{$ASMMODE ATT} {$ASMMODE ATT}

17
rtl/os2/sysheap.inc
View File

@ -1,10 +1,8 @@
{ {
This file is part of the Free Pascal run time library. This file is part of the Free Pascal run time library.
Copyright (c) 2001 by Free Pascal development team Copyright (c) 2001-2014 by Free Pascal development team
This file implements all the base types and limits required This file implements heap management for OS/2.
for a minimal POSIX compliant subset required to port the compiler
to a new OS.
See the file COPYING.FPC, included in this distribution, See the file COPYING.FPC, included in this distribution,
for details about the copyright. for details about the copyright.
@ -87,6 +85,7 @@ begin
else else
begin begin
SysOSAlloc := nil; SysOSAlloc := nil;
OSErrorWatch (RC);
{$IFDEF EXTDUMPGROW} {$IFDEF EXTDUMPGROW}
if Int_HeapSize <> high (cardinal) then if Int_HeapSize <> high (cardinal) then
begin begin
@ -104,25 +103,23 @@ end;
{$define HAS_SYSOSFREE} {$define HAS_SYSOSFREE}
procedure SysOSFree (P: pointer; Size: ptruint); procedure SysOSFree (P: pointer; Size: ptruint);
{$IFDEF EXTDUMPGROW}
var var
RC: cardinal; RC: cardinal;
{$ENDIF EXTDUMPGROW}
begin begin
{$IFDEF EXTDUMPGROW} {$IFDEF EXTDUMPGROW}
WriteLn ('Trying to free memory!'); WriteLn ('Trying to free memory!');
WriteLn ('Total allocated memory is ', Int_HeapSize); WriteLn ('Total allocated memory is ', Int_HeapSize);
Dec (Int_HeapSize, Size); Dec (Int_HeapSize, Size);
RC :=
{$ENDIF EXTDUMPGROW} {$ENDIF EXTDUMPGROW}
DosFreeMem (P); RC := DosFreeMem (P);
{$IFDEF EXTDUMPGROW}
if RC <> 0 then if RC <> 0 then
begin begin
OSErrorWatch (RC);
{$IFDEF EXTDUMPGROW}
WriteLn ('Error ', RC, ' during memory deallocation (DosFreeMem)!'); WriteLn ('Error ', RC, ' during memory deallocation (DosFreeMem)!');
WriteLn ('Total allocated memory is ', Int_HeapSize); WriteLn ('Total allocated memory is ', Int_HeapSize);
end;
{$ENDIF EXTDUMPGROW} {$ENDIF EXTDUMPGROW}
end;
end; end;

10
rtl/os2/sysos.inc
View File

@ -54,7 +54,7 @@ type
var var
ProcessID: SizeUInt; ProcessID: SizeUInt;
function GetProcessID:SizeUInt; function GetProcessID: SizeUInt;
begin begin
GetProcessID := ProcessID; GetProcessID := ProcessID;
end; end;
@ -420,3 +420,11 @@ external 'DOSCALLS' index 306;
function DosQuerySysInfo (First, Last: cardinal; var Buf; BufSize: cardinal): function DosQuerySysInfo (First, Last: cardinal; var Buf; BufSize: cardinal):
cardinal; cdecl; cardinal; cdecl;
external 'DOSCALLS' index 348; external 'DOSCALLS' index 348;
type
TCPArray = array [0..2] of cardinal;
PCPArray = ^TCPArray;
function DosQueryCP (Size: cardinal; CodePages: PCPArray;
var ActSize: cardinal): cardinal; cdecl;
external 'DOSCALLS' index 291;

197
rtl/os2/system.pas
View File

@ -110,6 +110,20 @@ const
(* Are file sizes > 2 GB (64-bit) supported on the current system? *) (* Are file sizes > 2 GB (64-bit) supported on the current system? *)
FSApi64: boolean = false; FSApi64: boolean = false;
(* Support for tracking I/O errors returned by OS/2 API calls - emulation *)
(* of GetLastError / fpGetError functionality used e.g. in Sysutils. *)
type
TOSErrorWatch = procedure (Error: cardinal);
procedure NoErrorTracking (Error: cardinal);
(* This shall be invoked whenever a non-zero error is returned by OS/2 APIs *)
(* used in the RTL. Direct OS/2 API calls in user programs are not covered! *)
const
OSErrorWatch: TOSErrorWatch = @NoErrorTracking;
procedure SetOSErrorTracking (P: pointer);
procedure SetDefaultOS2FileType (FType: ShortString); procedure SetDefaultOS2FileType (FType: ShortString);
@ -174,12 +188,15 @@ function Is_Prefetch (P: pointer): boolean;
InstrLo, InstrHi, OpCode: byte; InstrLo, InstrHi, OpCode: byte;
I: longint; I: longint;
MemSize, MemAttrs: cardinal; MemSize, MemAttrs: cardinal;
RC: cardinal;
begin begin
Is_Prefetch := false; Is_Prefetch := false;
MemSize := SizeOf (A); MemSize := SizeOf (A);
if (DosQueryMem (P, MemSize, MemAttrs) = 0) and RC := DosQueryMem (P, MemSize, MemAttrs);
(MemAttrs and (mfPag_Free or mfPag_Commit) <> 0) if RC <> 0 then
OSErrorWatch (RC)
else if (MemAttrs and (mfPag_Free or mfPag_Commit) <> 0)
and (MemSize >= SizeOf (A)) then and (MemSize >= SizeOf (A)) then
Move (P^, A [0], SizeOf (A)) Move (P^, A [0], SizeOf (A))
else else
@ -289,6 +306,7 @@ var
Res: cardinal; Res: cardinal;
Err: byte; Err: byte;
Must_Reset_FPU: boolean; Must_Reset_FPU: boolean;
RC: cardinal;
{$IFDEF SYSTEMEXCEPTIONDEBUG} {$IFDEF SYSTEMEXCEPTIONDEBUG}
CurSS: cardinal; CurSS: cardinal;
B: byte; B: byte;
@ -382,7 +400,9 @@ begin
{$ENDIF SYSTEMEXCEPTIONDEBUG} {$ENDIF SYSTEMEXCEPTIONDEBUG}
Report^.Exception_Num := 0; Report^.Exception_Num := 0;
Res := Xcpt_Continue_Execution; Res := Xcpt_Continue_Execution;
DosAcknowledgeSignalException (Report^.Parameters [0]); RC := DosAcknowledgeSignalException (Report^.Parameters [0]);
if RC <> 0 then
OSErrorWatch (RC);
end end
else else
Err := 217; Err := 217;
@ -443,7 +463,9 @@ begin
{$ENDIF SYSTEMEXCEPTIONDEBUG} {$ENDIF SYSTEMEXCEPTIONDEBUG}
Report^.Exception_Num := 0; Report^.Exception_Num := 0;
Res := Xcpt_Continue_Execution; Res := Xcpt_Continue_Execution;
DosAcknowledgeSignalException (Report^.Parameters [0]); RC := DosAcknowledgeSignalException (Report^.Parameters [0]);
if RC <> 0 then
OSErrorWatch (RC);
end end
else else
Err := 217; Err := 217;
@ -504,6 +526,7 @@ var
procedure Install_Exception_Handler; procedure Install_Exception_Handler;
var var
T: cardinal; T: cardinal;
RC: cardinal;
begin begin
{$ifdef SYSTEMEXCEPTIONDEBUG} {$ifdef SYSTEMEXCEPTIONDEBUG}
(* ThreadInfoBlock is located at FS:[0], the first *) (* ThreadInfoBlock is located at FS:[0], the first *)
@ -524,9 +547,15 @@ begin
DosSetExceptionHandler (ExcptReg^); DosSetExceptionHandler (ExcptReg^);
if IsConsole then if IsConsole then
begin begin
DosSetSignalExceptionFocus (1, T); RC := DosSetSignalExceptionFocus (1, T);
DosAcknowledgeSignalException (Xcpt_Signal_Intr); if RC <> 0 then
DosAcknowledgeSignalException (Xcpt_Signal_Break); OSErrorWatch (RC);
RC := DosAcknowledgeSignalException (Xcpt_Signal_Intr);
if RC <> 0 then
OSErrorWatch (RC);
RC := DosAcknowledgeSignalException (Xcpt_Signal_Break);
if RC <> 0 then
OSErrorWatch (RC);
end; end;
{$ifdef SYSTEMEXCEPTIONDEBUG} {$ifdef SYSTEMEXCEPTIONDEBUG}
asm asm
@ -538,8 +567,10 @@ begin
end; end;
procedure Remove_Exception_Handlers; procedure Remove_Exception_Handlers;
var
RC: cardinal;
begin begin
DosUnsetExceptionHandler (ExcptReg^); RC := DosUnsetExceptionHandler (ExcptReg^);
end; end;
{$ENDIF OS2EXCEPTIONS} {$ENDIF OS2EXCEPTIONS}
@ -686,6 +717,10 @@ begin
end; end;
procedure SysInitStdIO; procedure SysInitStdIO;
(*
var
RC: cardinal;
*)
begin begin
{ Setup stdin, stdout and stderr, for GUI apps redirect stderr,stdout to be { Setup stdin, stdout and stderr, for GUI apps redirect stderr,stdout to be
displayed in a messagebox } displayed in a messagebox }
@ -695,21 +730,36 @@ begin
StdErrorHandle := longint(GetStdHandle(cardinal(STD_ERROR_HANDLE))); StdErrorHandle := longint(GetStdHandle(cardinal(STD_ERROR_HANDLE)));
if not IsConsole then if not IsConsole then
begin begin
if (DosLoadModule (nil, 0, 'PMWIN', PMWinHandle) = 0) and RC := DosLoadModule (nil, 0, 'PMWIN', PMWinHandle);
(DosQueryProcAddr (PMWinHandle, 789, nil, pointer (WinMessageBox)) = 0) if RC <> 0 then
and OSErrorWatch (RC)
(DosQueryProcAddr (PMWinHandle, 763, nil, pointer (WinInitialize)) = 0) else
and begin
(DosQueryProcAddr (PMWinHandle, 716, nil, pointer (WinCreateMsgQueue)) RC := DosQueryProcAddr (PMWinHandle, 789, nil, pointer (WinMessageBox));
= 0) if RC <> 0 then
then OSErrorWatch (RC)
begin else
begin
RC := DosQueryProcAddr (PMWinHandle, 763, nil, pointer (WinInitialize));
if RC <> 0 then
OSErrorWatch (RC)
else
begin
RC := DosQueryProcAddr (PMWinHandle, 716, nil, pointer (WinCreateMsgQueue));
if RC <> 0 then
OSErrorWatch (RC)
else
begin
WinInitialize (0); WinInitialize (0);
WinCreateMsgQueue (0, 0); WinCreateMsgQueue (0, 0);
end end
else end
HandleError (2); end
end;
if RC <> 0 then
HandleError (2);
AssignError (StdErr); AssignError (StdErr);
AssignError (StdOut); AssignError (StdOut);
Assign (Output, ''); Assign (Output, '');
@ -824,6 +874,21 @@ begin
end; end;
(* The default handler does not store the OS/2 API error codes. *)
procedure NoErrorTracking (Error: cardinal);
begin
end;
procedure SetOSErrorTracking (P: pointer);
begin
if P = nil then
OSErrorWatch := @NoErrorTracking
else
OSErrorWatch := TOSErrorWatch (P);
end;
procedure InitEnvironment; procedure InitEnvironment;
var env_count : longint; var env_count : longint;
dos_env,cp : pchar; dos_env,cp : pchar;
@ -870,6 +935,7 @@ var
pc,arg : pchar; pc,arg : pchar;
quote : char; quote : char;
argvlen : PtrInt; argvlen : PtrInt;
RC: cardinal;
procedure allocarg(idx,len: PtrInt); procedure allocarg(idx,len: PtrInt);
var var
@ -896,7 +962,8 @@ begin
ArgLen := StrLen (PChar (PIB^.Cmd)); ArgLen := StrLen (PChar (PIB^.Cmd));
Inc (ArgLen); Inc (ArgLen);
if DosQueryModuleName (PIB^.Handle, MaxPathLen, CmdLine) = 0 then RC := DosQueryModuleName (PIB^.Handle, MaxPathLen, CmdLine);
if RC = 0 then
ArgVLen := Succ (StrLen (CmdLine)) ArgVLen := Succ (StrLen (CmdLine))
else else
(* Error occurred - use program name from command line as fallback. *) (* Error occurred - use program name from command line as fallback. *)
@ -1070,10 +1137,17 @@ end;
function GetFileHandleCount: longint; function GetFileHandleCount: longint;
var L1: longint; var L1: longint;
L2: cardinal; L2: cardinal;
RC: cardinal;
begin begin
L1 := 0; (* Don't change the amount, just check. *) L1 := 0; (* Don't change the amount, just check. *)
if DosSetRelMaxFH (L1, L2) <> 0 then GetFileHandleCount := 50 RC := DosSetRelMaxFH (L1, L2);
else GetFileHandleCount := L2; if RC <> 0 then
begin
GetFileHandleCount := 50;
OSErrorWatch (RC);
end
else
GetFileHandleCount := L2;
end; end;
function CheckInitialStkLen (StkLen: SizeUInt): SizeUInt; function CheckInitialStkLen (StkLen: SizeUInt): SizeUInt;
@ -1086,6 +1160,8 @@ var TIB: PThreadInfoBlock;
ErrStr: string; ErrStr: string;
P: pointer; P: pointer;
DW: cardinal; DW: cardinal;
CPArr: TCPArray;
ReturnedSize: cardinal;
const const
DosCallsName: array [0..8] of char = 'DOSCALLS'#0; DosCallsName: array [0..8] of char = 'DOSCALLS'#0;
@ -1094,29 +1170,9 @@ const
{$I sysucode.inc} {$I sysucode.inc}
{$ENDIF OS2UNICODE} {$ENDIF OS2UNICODE}
{*var}
{* ST: pointer;}
{*}
begin begin
{$IFDEF OS2EXCEPTIONS} {$IFDEF OS2EXCEPTIONS}
(* asm asm
{ allocate space for exception registration record }
pushl $0
pushl $0}
{* pushl %fs:(0)}
{ movl %esp,%fs:(0)
but don't insert it as it doesn't
point to anything yet
this will be used in signals unit }
movl %esp,%eax
movl %eax,ExcptReg
pushl %ebp
movl %esp,%eax
{* movl %eax,st*}
movl %eax,StackTop
end;
{* StackTop:=st;}
*) asm
xorl %eax,%eax xorl %eax,%eax
movw %ss,%ax movw %ss,%ax
movl %eax,_SS movl %eax,_SS
@ -1166,24 +1222,28 @@ begin
from the high memory region before changing value of this variable. *) from the high memory region before changing value of this variable. *)
InitHeap; InitHeap;
if DosQueryModuleHandle (@DosCallsName [0], DosCallsHandle) = 0 then RC := DosQueryModuleHandle (@DosCallsName [0], DosCallsHandle);
begin if RC = 0 then
if DosQueryProcAddr (DosCallsHandle, OrdDosOpenL, nil, P) = 0 then begin
begin RC := DosQueryProcAddr (DosCallsHandle, OrdDosOpenL, nil, P);
Sys_DosOpenL := TDosOpenL (P); if RC = 0 then
if DosQueryProcAddr (DosCallsHandle, OrdDosSetFilePtrL, nil, P) = 0 begin
then Sys_DosOpenL := TDosOpenL (P);
begin RC := DosQueryProcAddr (DosCallsHandle, OrdDosSetFilePtrL, nil, P);
Sys_DosSetFilePtrL := TDosSetFilePtrL (P); if RC = 0 then
if DosQueryProcAddr (DosCallsHandle, OrdDosSetFileSizeL, nil, begin
P) = 0 then Sys_DosSetFilePtrL := TDosSetFilePtrL (P);
begin RC := DosQueryProcAddr (DosCallsHandle, OrdDosSetFileSizeL, nil, P);
Sys_DosSetFileSizeL := TDosSetFileSizeL (P); if RC = 0 then
FSApi64 := true; begin
end; Sys_DosSetFileSizeL := TDosSetFileSizeL (P);
end; FSApi64 := true;
end; end;
end; end;
end;
end;
if RC <> 0 then
OSErrorWatch (RC);
{ ... and exceptions } { ... and exceptions }
SysInitExceptions; SysInitExceptions;
@ -1220,4 +1280,15 @@ begin
WriteLn (StdErr, 'Old exception ', HexStr (OldExceptAddr, 8), WriteLn (StdErr, 'Old exception ', HexStr (OldExceptAddr, 8),
', new exception ', HexStr (NewExceptAddr, 8), ', _SS = ', HexStr (_SS, 8)); ', new exception ', HexStr (NewExceptAddr, 8), ', _SS = ', HexStr (_SS, 8));
{$endif SYSTEMEXCEPTIONDEBUG} {$endif SYSTEMEXCEPTIONDEBUG}
RC := DosQueryCP (SizeOf (CPArr), @CPArr, ReturnedSize);
if RC <> 0 then
OSErrorWatch (RC)
else if (ReturnedSize >= 4) then
begin
DefaultSystemCodePage := CPArr [0];
DefaultRTLFileSystemCodePage := DefaultSystemCodePage;
DefaultFileSystemCodePage := DefaultSystemCodePage;
DefaultUnicodeCodePage := CP_UTF16;
end;
end. end.

192
rtl/os2/systhrd.inc
View File

@ -195,15 +195,21 @@ end;
procedure SysAllocateThreadVars; procedure SysAllocateThreadVars;
var
RC: cardinal;
begin begin
{ we've to allocate the memory from the OS } { we've to allocate the memory from the OS }
{ because the FPC heap management uses } { because the FPC heap management uses }
{ exceptions which use threadvars but } { exceptions which use threadvars but }
{ these aren't allocated yet ... } { these aren't allocated yet ... }
{ allocate room on the heap for the thread vars } { allocate room on the heap for the thread vars }
if DosAllocMem (DataIndex^, ThreadVarBlockSize, pag_Read or pag_Write RC := DosAllocMem (DataIndex^, ThreadVarBlockSize, pag_Read or pag_Write
or pag_Commit) <> 0 then or pag_Commit);
HandleError (8); if RC <> 0 then
begin
OSErrorWatch (RC);
HandleError (8);
end;
{ The Windows API apparently provides a way to fill the allocated memory with } { The Windows API apparently provides a way to fill the allocated memory with }
{ zeros; we probably need to do it ourselves for compatibility. } { zeros; we probably need to do it ourselves for compatibility. }
FillChar (DataIndex^^, 0, ThreadVarBlockSize); FillChar (DataIndex^^, 0, ThreadVarBlockSize);
@ -240,12 +246,16 @@ end;
procedure SysFiniMultithreading; procedure SysFiniMultithreading;
var
RC: cardinal;
begin begin
if IsMultiThread then if IsMultiThread then
begin begin
if DosFreeThreadLocalMemory (DataIndex) <> 0 then RC := DosFreeThreadLocalMemory (DataIndex);
if RC <> 0 then
begin begin
{??? What to do if releasing fails?} {??? What to do if releasing fails?}
OSErrorWatch (RC);
end; end;
DataIndex := nil; DataIndex := nil;
end; end;
@ -253,9 +263,13 @@ end;
procedure SysReleaseThreadVars; procedure SysReleaseThreadVars;
var
RC: cardinal;
begin begin
DosFreeMem (DataIndex^); RC := DosFreeMem (DataIndex^);
DataIndex^ := nil; if RC <> 0 then
OSErrorWatch (RC);
DataIndex^ := nil;
end; end;
@ -334,6 +348,7 @@ function SysBeginThread (SA: pointer; StackSize : PtrUInt;
CreationFlags: cardinal; var ThreadId: TThreadID): DWord; CreationFlags: cardinal; var ThreadId: TThreadID): DWord;
var var
TI: PThreadInfo; TI: PThreadInfo;
RC: cardinal;
begin begin
{ WriteLn is not a good idea before thread initialization... { WriteLn is not a good idea before thread initialization...
$ifdef DEBUG_MT $ifdef DEBUG_MT
@ -351,8 +366,9 @@ begin
{$ifdef DEBUG_MT} {$ifdef DEBUG_MT}
WriteLn ('Starting new thread'); WriteLn ('Starting new thread');
{$endif DEBUG_MT} {$endif DEBUG_MT}
if DosCreateThread (cardinal (ThreadID), @ThreadMain, TI, RC := DosCreateThread (cardinal (ThreadID), @ThreadMain, TI,
CreationFlags, StackSize) = 0 then CreationFlags, StackSize);
if RC = 0 then
SysBeginThread := ThreadID SysBeginThread := ThreadID
else else
begin begin
@ -361,6 +377,7 @@ begin
WriteLn ('Thread creation failed'); WriteLn ('Thread creation failed');
{$ENDIF DEBUG_MT} {$ENDIF DEBUG_MT}
Dispose (TI); Dispose (TI);
OSErrorWatch (RC);
end; end;
end; end;
@ -379,40 +396,62 @@ end;
function SysSuspendThread (ThreadHandle: dword): dword; function SysSuspendThread (ThreadHandle: dword): dword;
var
RC: cardinal;
begin begin
{$WARNING Check expected return value} {$WARNING Check expected return value}
SysSuspendThread := DosSuspendThread (ThreadHandle); RC := DosSuspendThread (ThreadHandle);
SysSuspendThread := RC;
if RC <> 0 then
OSErrorWatch (RC);
end; end;
function SysResumeThread (ThreadHandle: dword): dword; function SysResumeThread (ThreadHandle: dword): dword;
var
RC: cardinal;
begin begin
{$WARNING Check expected return value} {$WARNING Check expected return value}
SysResumeThread := DosResumeThread (ThreadHandle); RC := DosResumeThread (ThreadHandle);
SysResumeThread := RC;
if RC <> 0 then
OSErrorWatch (RC);
end; end;
function SysKillThread (ThreadHandle: dword): dword; function SysKillThread (ThreadHandle: dword): dword;
var
RC: cardinal;
begin begin
SysKillThread := DosKillThread (ThreadHandle); RC := DosKillThread (ThreadHandle);
SysKillThread := RC;
if RC <> 0 then
OSErrorWatch (RC);
end; end;
{$PUSH}
{$WARNINGS OFF}
function SysCloseThread (ThreadHandle: TThreadID): dword; function SysCloseThread (ThreadHandle: TThreadID): dword;
begin begin
{ Probably not relevant under OS/2? } { Probably not relevant under OS/2? }
// SysCloseThread:=CloseHandle(threadHandle); // SysCloseThread:=CloseHandle(threadHandle);
end; end;
{$POP}
function SysWaitForThreadTerminate (ThreadHandle: dword; function SysWaitForThreadTerminate (ThreadHandle: dword;
TimeoutMs: longint): dword; TimeoutMs: longint): dword;
var var
RC: cardinal; RC, RC2: cardinal;
const const
{ Wait at most 100 ms before next check for thread termination } { Wait at most 100 ms before next check for thread termination }
WaitTime = 100; WaitTime = 100;
begin begin
if TimeoutMs = 0 then if TimeoutMs = 0 then
RC := DosWaitThread (ThreadHandle, dcWW_Wait) begin
RC := DosWaitThread (ThreadHandle, dcWW_Wait);
if RC <> 0 then
OSErrorWatch (RC);
end
else else
repeat repeat
RC := DosWaitThread (ThreadHandle, dcWW_NoWait); RC := DosWaitThread (ThreadHandle, dcWW_NoWait);
@ -423,10 +462,14 @@ begin
else else
begin begin
DosSleep (TimeoutMs); DosSleep (TimeoutMs);
DosWaitThread (ThreadHandle, dcWW_NoWait); RC2 := DosWaitThread (ThreadHandle, dcWW_NoWait);
if RC2 <> 0 then
OSErrorWatch (RC2);
end; end;
Dec (TimeoutMs, WaitTime); Dec (TimeoutMs, WaitTime);
end; end
else if RC <> 0 then
OSErrorWatch (RC);
until (RC <> 294) or (TimeoutMs <= 0); until (RC <> 294) or (TimeoutMs <= 0);
SysWaitForThreadTerminate := RC; SysWaitForThreadTerminate := RC;
end; end;
@ -451,7 +494,9 @@ begin
else else
begin begin
RC := DosQuerySysState (qs_Process, 0, ProcessID, 0, PPtrRec^, BufSize); RC := DosQuerySysState (qs_Process, 0, ProcessID, 0, PPtrRec^, BufSize);
if (RC = 0) and (PPtrRec^.PProcRec <> nil) if RC <> 0 then
OSErrorWatch (RC)
else if (PPtrRec^.PProcRec <> nil)
and (PPtrRec^.PProcRec^.PThrdRec <> nil) then and (PPtrRec^.PProcRec^.PThrdRec <> nil) then
begin begin
BufEnd := PtrUInt (PPtrRec) + BufSize; BufEnd := PtrUInt (PPtrRec) + BufSize;
@ -480,6 +525,7 @@ function SysThreadSetPriority (ThreadHandle: dword; Prio: longint): boolean;
var var
Delta: longint; Delta: longint;
Priority: cardinal; Priority: cardinal;
RC: cardinal;
begin begin
Priority := GetOS2ThreadPriority (ThreadHandle); Priority := GetOS2ThreadPriority (ThreadHandle);
if Priority > High (word) then if Priority > High (word) then
@ -491,8 +537,10 @@ begin
Delta := - TPrio (Priority).PrioLevel Delta := - TPrio (Priority).PrioLevel
else if Delta + TPrio (Priority).PrioLevel > 31 then else if Delta + TPrio (Priority).PrioLevel > 31 then
Delta := 31 - TPrio (Priority).PrioLevel; Delta := 31 - TPrio (Priority).PrioLevel;
SysThreadSetPriority := RC := DosSetPriority (dpThread, dpSameClass, Delta, ThreadHandle);
DosSetPriority (dpThread, dpSameClass, Delta, ThreadHandle) = 0; if RC <> 0 then
OSErrorWatch (RC);
SysThreadSetPriority := RC = 0;
end; end;
end; end;
@ -529,25 +577,43 @@ end;
*****************************************************************************} *****************************************************************************}
procedure SysInitCriticalSection (var CS); procedure SysInitCriticalSection (var CS);
var
RC: cardinal;
begin begin
if DosCreateMutExSem (nil, THandle (CS), 0, 0) <> 0 then RC := DosCreateMutExSem (nil, THandle (CS), 0, 0);
FPC_ThreadError; if RC <> 0 then
begin
OSErrorWatch (RC);
FPC_ThreadError;
end;
end; end;
procedure SysDoneCriticalSection (var CS); procedure SysDoneCriticalSection (var CS);
var
RC: cardinal;
begin begin
(* Trying to release first since this might apparently be the expected *) (* Trying to release first since this might apparently be the expected *)
(* behaviour in Delphi according to comment in the Unix implementation. *) (* behaviour in Delphi according to comment in the Unix implementation. *)
repeat repeat
until DosReleaseMutExSem (THandle (CS)) <> 0; until DosReleaseMutExSem (THandle (CS)) <> 0;
if DosCloseMutExSem (THandle (CS)) <> 0 then RC := DosCloseMutExSem (THandle (CS));
FPC_ThreadError; if RC <> 0 then
begin
OSErrorWatch (RC);
FPC_ThreadError;
end;
end; end;
procedure SysEnterCriticalSection (var CS); procedure SysEnterCriticalSection (var CS);
var
RC: cardinal;
begin begin
if DosRequestMutExSem (THandle (CS), cardinal (-1)) <> 0 then RC := DosRequestMutExSem (THandle (CS), cardinal (-1));
FPC_ThreadError; if RC <> 0 then
begin
OSErrorWatch (RC);
FPC_ThreadError;
end;
end; end;
function SysTryEnterCriticalSection (var CS): longint; function SysTryEnterCriticalSection (var CS): longint;
@ -559,9 +625,15 @@ begin
end; end;
procedure SysLeaveCriticalSection (var CS); procedure SysLeaveCriticalSection (var CS);
var
RC: cardinal;
begin begin
if DosReleaseMutExSem (THandle (CS)) <> 0 then RC := DosReleaseMutExSem (THandle (CS));
FPC_ThreadError; if RC <> 0 then
begin
OSErrorWatch (RC);
FPC_ThreadError;
end;
end; end;
@ -607,18 +679,23 @@ begin
if RC <> 0 then if RC <> 0 then
begin begin
Dispose (PLocalEventRec (Result)); Dispose (PLocalEventRec (Result));
OSErrorWatch (RC);
FPC_ThreadError; FPC_ThreadError;
end; end;
end; end;
procedure SysBasicEventDestroy (State: PEventState); procedure SysBasicEventDestroy (State: PEventState);
var
RC: cardinal;
begin begin
if State = nil then if State = nil then
FPC_ThreadError FPC_ThreadError
else else
begin begin
DosCloseEventSem (PLocalEventRec (State)^.FHandle); RC := DosCloseEventSem (PLocalEventRec (State)^.FHandle);
if RC <> 0 then
OSErrorWatch (RC);
Dispose (PLocalEventRec (State)); Dispose (PLocalEventRec (State));
end; end;
end; end;
@ -627,22 +704,33 @@ end;
procedure SysBasicEventResetEvent (State: PEventState); procedure SysBasicEventResetEvent (State: PEventState);
var var
PostCount: cardinal; PostCount: cardinal;
RC: cardinal;
begin begin
if State = nil then if State = nil then
FPC_ThreadError FPC_ThreadError
else else
begin
(* In case of later addition of error checking: *) (* In case of later addition of error checking: *)
(* RC 300 = Error_Already_Reset which would be OK. *) (* RC 300 = Error_Already_Reset which would be OK. *)
DosResetEventSem (PLocalEventRec (State)^.FHandle, PostCount); RC := DosResetEventSem (PLocalEventRec (State)^.FHandle, PostCount);
if (RC <> 0) and (RC <> 300) then
OSErrorWatch (RC);
end;
end; end;
procedure SysBasicEventSetEvent (State: PEventState); procedure SysBasicEventSetEvent (State: PEventState);
var
RC: cardinal;
begin begin
if State = nil then if State = nil then
FPC_ThreadError FPC_ThreadError
else else
DosPostEventSem (PLocalEventRec (State)^.FHandle); begin
RC := DosPostEventSem (PLocalEventRec (State)^.FHandle);
if RC <> 0 then
OSErrorWatch (RC);
end;
end; end;
@ -661,6 +749,7 @@ begin
else else
begin begin
Result := wrError; Result := wrError;
OSErrorWatch (RC);
PLocalEventRec (State)^.FLastError := RC; PLocalEventRec (State)^.FLastError := RC;
end; end;
end; end;
@ -669,41 +758,64 @@ end;
function SysRTLEventCreate: PRTLEvent; function SysRTLEventCreate: PRTLEvent;
var
RC: cardinal;
begin begin
Result := PRTLEvent (-1); Result := PRTLEvent (-1);
DosCreateEventSem (nil, THandle (Result), dce_AutoReset, 0); RC := DosCreateEventSem (nil, THandle (Result), dce_AutoReset, 0);
if RC <> 0 then
OSErrorWatch (RC);
end; end;
procedure SysRTLEventDestroy (AEvent: PRTLEvent); procedure SysRTLEventDestroy (AEvent: PRTLEvent);
var
RC: cardinal;
begin begin
DosCloseEventSem (THandle (AEvent)); RC := DosCloseEventSem (THandle (AEvent));
if RC <> 0 then
OSErrorWatch (RC);
end; end;
procedure SysRTLEventSetEvent (AEvent: PRTLEvent); procedure SysRTLEventSetEvent (AEvent: PRTLEvent);
var
RC: cardinal;
begin begin
DosPostEventSem (THandle (AEvent)); RC := DosPostEventSem (THandle (AEvent));
if RC <> 0 then
OSErrorWatch (RC);
end; end;
procedure SysRTLEventWaitFor (AEvent: PRTLEvent); procedure SysRTLEventWaitFor (AEvent: PRTLEvent);
var
RC: cardinal;
begin begin
DosWaitEventSem (THandle (AEvent), cardinal (-1)); RC := DosWaitEventSem (THandle (AEvent), cardinal (-1));
if RC <> 0 then
OSErrorWatch (RC);
end; end;
procedure SysRTLEventWaitForTimeout (AEvent: PRTLEvent; Timeout: longint); procedure SysRTLEventWaitForTimeout (AEvent: PRTLEvent; Timeout: longint);
var
RC: cardinal;
begin begin
DosWaitEventSem (THandle (AEvent), Timeout); RC := DosWaitEventSem (THandle (AEvent), Timeout);
if RC <> 0 then
OSErrorWatch (RC);
end; end;
procedure SysRTLEventResetEvent (AEvent: PRTLEvent); procedure SysRTLEventResetEvent (AEvent: PRTLEvent);
var var
PostCount: cardinal; PostCount: cardinal;
RC: cardinal;
begin begin
DosResetEventSem (THandle (AEvent), PostCount); RC := DosResetEventSem (THandle (AEvent), PostCount);
if RC <> 0 then
OSErrorWatch (RC);
end; end;
@ -713,11 +825,15 @@ const
svNumProcessors = 26; svNumProcessors = 26;
var var
ProcNum: cardinal; ProcNum: cardinal;
RC: cardinal;
begin begin
GetCPUCount := 1; GetCPUCount := 1;
if DosQuerySysInfo (svNumProcessors, svNumProcessors, ProcNum, RC := DosQuerySysInfo (svNumProcessors, svNumProcessors, ProcNum,
SizeOf (ProcNum)) = 0 then SizeOf (ProcNum));
GetCPUCount := ProcNum; if RC = 0 then
GetCPUCount := ProcNum
else
OSErrorWatch (RC);
end; end;

391
rtl/os2/sysutils.pp
View File

@ -23,6 +23,7 @@ interface
{$H+} {$H+}
{$DEFINE HAS_SLEEP} {$DEFINE HAS_SLEEP}
{$DEFINE HAS_OSERROR}
{ used OS file system APIs use ansistring } { used OS file system APIs use ansistring }
{$define SYSUTILS_HAS_ANSISTR_FILEUTIL_IMPL} {$define SYSUTILS_HAS_ANSISTR_FILEUTIL_IMPL}
@ -83,8 +84,11 @@ begin
If Rc=0 then If Rc=0 then
FileOpen:=Handle FileOpen:=Handle
else else
begin
FileOpen:=feInvalidHandle; //FileOpen:=-RC; FileOpen:=feInvalidHandle; //FileOpen:=-RC;
//should return feInvalidHandle(=-1) if fail, other negative returned value are no more errors //should return feInvalidHandle(=-1) if fail, other negative returned value are no more errors
OSErrorWatch (RC);
end;
end; end;
function FileCreate (const FileName: RawByteString): THandle; function FileCreate (const FileName: RawByteString): THandle;
@ -115,56 +119,84 @@ begin
if RC = 0 then if RC = 0 then
FileCreate := Handle FileCreate := Handle
else else
FileCreate := feInvalidHandle; begin
FileCreate := feInvalidHandle;
OSErrorWatch (RC);
end;
End; End;
function FileRead (Handle: THandle; Out Buffer; Count: longint): longint; function FileRead (Handle: THandle; Out Buffer; Count: longint): longint;
Var Var
T: cardinal; T: cardinal;
RC: cardinal;
begin begin
DosRead(Handle, Buffer, Count, T); RC := DosRead (Handle, Buffer, Count, T);
FileRead := longint (T); FileRead := longint (T);
if RC <> 0 then
OSErrorWatch (RC);
end; end;
function FileWrite (Handle: THandle; const Buffer; Count: longint): longint; function FileWrite (Handle: THandle; const Buffer; Count: longint): longint;
Var Var
T: cardinal; T: cardinal;
RC: cardinal;
begin begin
DosWrite (Handle, Buffer, Count, T); RC := DosWrite (Handle, Buffer, Count, T);
FileWrite := longint (T); FileWrite := longint (T);
if RC <> 0 then
OSErrorWatch (RC);
end; end;
function FileSeek (Handle: THandle; FOffset, Origin: longint): longint; function FileSeek (Handle: THandle; FOffset, Origin: longint): longint;
var var
NPos: int64; NPos: int64;
RC: cardinal;
begin begin
if (Sys_DosSetFilePtrL (Handle, FOffset, Origin, NPos) = 0) RC := Sys_DosSetFilePtrL (Handle, FOffset, Origin, NPos);
and (NPos < high (longint)) then if (RC = 0) and (NPos < high (longint)) then
FileSeek:= longint (NPos) FileSeek:= longint (NPos)
else else
begin
FileSeek:=-1; FileSeek:=-1;
OSErrorWatch (RC);
end;
end; end;
function FileSeek (Handle: THandle; FOffset: Int64; Origin: Longint): Int64; function FileSeek (Handle: THandle; FOffset: Int64; Origin: Longint): Int64;
var var
NPos: int64; NPos: int64;
RC: cardinal;
begin begin
if Sys_DosSetFilePtrL (Handle, FOffset, Origin, NPos) = 0 then RC := Sys_DosSetFilePtrL (Handle, FOffset, Origin, NPos);
if RC = 0 then
FileSeek:= NPos FileSeek:= NPos
else else
begin
FileSeek:=-1; FileSeek:=-1;
OSErrorWatch (RC);
end;
end; end;
procedure FileClose (Handle: THandle); procedure FileClose (Handle: THandle);
var
RC: cardinal;
begin begin
DosClose(Handle); RC := DosClose (Handle);
if RC <> 0 then
OSErrorWatch (RC);
end; end;
function FileTruncate (Handle: THandle; Size: Int64): boolean; function FileTruncate (Handle: THandle; Size: Int64): boolean;
var
RC: cardinal;
begin begin
FileTruncate:=Sys_DosSetFileSizeL(Handle, Size)=0; RC := Sys_DosSetFileSizeL(Handle, Size);
FileSeek(Handle, 0, 2); FileTruncate := RC = 0;
if RC = 0 then
FileSeek(Handle, 0, 2)
else
OSErrorWatch (RC);
end; end;
function FileAge (const FileName: RawByteString): longint; function FileAge (const FileName: RawByteString): longint;
@ -222,7 +254,9 @@ begin
else else
Err := DosFindFirst (PChar (SystemEncodedPath), Rslt.FindHandle, Err := DosFindFirst (PChar (SystemEncodedPath), Rslt.FindHandle,
Attr and FindResvdMask, FStat, SizeOf (FStat^), Count, ilStandard); Attr and FindResvdMask, FStat, SizeOf (FStat^), Count, ilStandard);
if (Err = 0) and (Count = 0) then if Err <> 0 then
OSErrorWatch (Err)
else if Count = 0 then
Err := 18; Err := 18;
InternalFindFirst := -Err; InternalFindFirst := -Err;
if Err = 0 then if Err = 0 then
@ -261,7 +295,9 @@ begin
New (FStat); New (FStat);
Count := 1; Count := 1;
Err := DosFindNext (Rslt.FindHandle, FStat, SizeOf (FStat^), Count); Err := DosFindNext (Rslt.FindHandle, FStat, SizeOf (FStat^), Count);
if (Err = 0) and (Count = 0) then if Err <> 0 then
OSErrorWatch (Err)
else if Count = 0 then
Err := 18; Err := 18;
InternalFindNext := -Err; InternalFindNext := -Err;
if Err = 0 then if Err = 0 then
@ -290,9 +326,12 @@ end;
Procedure InternalFindClose(var Handle: THandle); Procedure InternalFindClose(var Handle: THandle);
var var
SR: PSearchRec; SR: PSearchRec;
RC: cardinal;
begin begin
DosFindClose (Handle); RC := DosFindClose (Handle);
Handle := 0; Handle := 0;
if RC <> 0 then
OSErrorWatch (RC);
end; end;
function FileGetDate (Handle: THandle): longint; function FileGetDate (Handle: THandle): longint;
@ -308,7 +347,10 @@ begin
if Time = 0 then if Time = 0 then
Time := FStat.TimeCreation + longint (FStat.DateCreation) shl 16; Time := FStat.TimeCreation + longint (FStat.DateCreation) shl 16;
end else end else
begin
Time:=0; Time:=0;
OSErrorWatch (RC);
end;
FileGetDate:=Time; FileGetDate:=Time;
end; end;
@ -320,19 +362,25 @@ begin
New (FStat); New (FStat);
RC := DosQueryFileInfo (Handle, ilStandard, FStat, SizeOf (FStat^)); RC := DosQueryFileInfo (Handle, ilStandard, FStat, SizeOf (FStat^));
if RC <> 0 then if RC <> 0 then
FileSetDate := -1 begin
FileSetDate := -1;
OSErrorWatch (RC);
end
else else
begin begin
FStat^.DateLastAccess := Hi (Age); FStat^.DateLastAccess := Hi (Age);
FStat^.DateLastWrite := Hi (Age); FStat^.DateLastWrite := Hi (Age);
FStat^.TimeLastAccess := Lo (Age); FStat^.TimeLastAccess := Lo (Age);
FStat^.TimeLastWrite := Lo (Age); FStat^.TimeLastWrite := Lo (Age);
RC := DosSetFileInfo (Handle, ilStandard, FStat, SizeOf (FStat^)); RC := DosSetFileInfo (Handle, ilStandard, FStat, SizeOf (FStat^));
if RC <> 0 then if RC <> 0 then
FileSetDate := -1 begin
FileSetDate := -1;
OSErrorWatch (RC);
end
else else
FileSetDate := 0; FileSetDate := 0;
end; end;
Dispose (FStat); Dispose (FStat);
end; end;
@ -340,11 +388,18 @@ function FileGetAttr (const FileName: RawByteString): longint;
var var
FS: PFileStatus3; FS: PFileStatus3;
SystemFileName: RawByteString; SystemFileName: RawByteString;
RC: cardinal;
begin begin
SystemFileName:=ToSingleByteFileSystemEncodedFileName(Filename); SystemFileName:=ToSingleByteFileSystemEncodedFileName(Filename);
New(FS); New(FS);
Result:=-DosQueryPathInfo(PChar (SystemFileName), ilStandard, FS, SizeOf(FS^)); RC := DosQueryPathInfo(PChar (SystemFileName), ilStandard, FS, SizeOf(FS^));
If Result=0 Then Result:=FS^.attrFile; if RC = 0 then
Result := FS^.AttrFile
else
begin
Result := - longint (RC);
OSErrorWatch (RC);
end;
Dispose(FS); Dispose(FS);
end; end;
@ -352,12 +407,16 @@ function FileSetAttr (const Filename: RawByteString; Attr: longint): longint;
Var Var
FS: PFileStatus3; FS: PFileStatus3;
SystemFileName: RawByteString; SystemFileName: RawByteString;
RC: cardinal;
Begin Begin
SystemFileName:=ToSingleByteFileSystemEncodedFileName(Filename); SystemFileName:=ToSingleByteFileSystemEncodedFileName(Filename);
New(FS); New(FS);
FillChar(FS, SizeOf(FS^), 0); FillChar(FS, SizeOf(FS^), 0);
FS^.AttrFile:=Attr; FS^.AttrFile:=Attr;
Result:=-DosSetPathInfo(PChar (SystemFileName), ilStandard, FS, SizeOf(FS^), 0); RC := DosSetPathInfo(PChar (SystemFileName), ilStandard, FS, SizeOf(FS^), 0);
if RC <> 0 then
OSErrorWatch (RC);
Result := - longint (RC);
Dispose(FS); Dispose(FS);
end; end;
@ -365,18 +424,34 @@ end;
function DeleteFile (const FileName: RawByteString): boolean; function DeleteFile (const FileName: RawByteString): boolean;
var var
SystemFileName: RawByteString; SystemFileName: RawByteString;
RC: cardinal;
Begin Begin
SystemFileName:=ToSingleByteFileSystemEncodedFileName(Filename); SystemFileName:=ToSingleByteFileSystemEncodedFileName(Filename);
Result:=(DosDelete(PChar (SystemFileName))=0); RC := DosDelete (PChar (SystemFileName));
if RC <> 0 then
begin
Result := false;
OSErrorWatch (RC);
end
else
Result := true;
End; End;
function RenameFile (const OldName, NewName: RawByteString): boolean; function RenameFile (const OldName, NewName: RawByteString): boolean;
var var
OldSystemFileName, NewSystemFileName: RawByteString; OldSystemFileName, NewSystemFileName: RawByteString;
RC: cardinal;
Begin Begin
OldSystemFileName:=ToSingleByteFileSystemEncodedFileName(OldName); OldSystemFileName:=ToSingleByteFileSystemEncodedFileName(OldName);
NewSystemFileName:=ToSingleByteFileSystemEncodedFileName(NewName); NewSystemFileName:=ToSingleByteFileSystemEncodedFileName(NewName);
Result:=(DosMove(PChar (OldSystemFileName), PChar (NewSystemFileName))=0); RC := DosMove (PChar (OldSystemFileName), PChar (NewSystemFileName));
if RC <> 0 then
begin
Result := false;
OSErrorWatch (RC);
end
else
Result := true;
End; End;
{**************************************************************************** {****************************************************************************
@ -389,13 +464,16 @@ var FI: TFSinfo;
RC: cardinal; RC: cardinal;
begin begin
{In OS/2, we use the filesystem information.} {In OS/2, we use the filesystem information.}
RC := DosQueryFSInfo (Drive, 1, FI, SizeOf (FI)); RC := DosQueryFSInfo (Drive, 1, FI, SizeOf (FI));
if RC = 0 then if RC = 0 then
DiskFree := int64 (FI.Free_Clusters) * DiskFree := int64 (FI.Free_Clusters) *
int64 (FI.Sectors_Per_Cluster) * int64 (FI.Bytes_Per_Sector) int64 (FI.Sectors_Per_Cluster) * int64 (FI.Bytes_Per_Sector)
else else
DiskFree := -1; begin
DiskFree := -1;
OSErrorWatch (RC);
end;
end; end;
function DiskSize (Drive: byte): int64; function DiskSize (Drive: byte): int64;
@ -404,13 +482,16 @@ var FI: TFSinfo;
RC: cardinal; RC: cardinal;
begin begin
{In OS/2, we use the filesystem information.} {In OS/2, we use the filesystem information.}
RC := DosQueryFSinfo (Drive, 1, FI, SizeOf (FI)); RC := DosQueryFSinfo (Drive, 1, FI, SizeOf (FI));
if RC = 0 then if RC = 0 then
DiskSize := int64 (FI.Total_Clusters) * DiskSize := int64 (FI.Total_Clusters) *
int64 (FI.Sectors_Per_Cluster) * int64 (FI.Bytes_Per_Sector) int64 (FI.Sectors_Per_Cluster) * int64 (FI.Bytes_Per_Sector)
else else
DiskSize := -1; begin
DiskSize := -1;
OSErrorWatch (RC);
end;
end; end;
@ -469,17 +550,21 @@ end;
procedure sysbeep; procedure sysbeep;
begin begin
// Maybe implement later on ? DosBeep (800, 250);
end; end;
{**************************************************************************** {****************************************************************************
Locale Functions Locale Functions
****************************************************************************} ****************************************************************************}
var
Country: TCountryCode;
CtryInfo: TCountryInfo;
procedure InitAnsi; procedure InitAnsi;
var I: byte; var
Country: TCountryCode; I: byte;
RC: cardinal;
begin begin
for I := 0 to 255 do for I := 0 to 255 do
UpperCaseTable [I] := Chr (I); UpperCaseTable [I] := Chr (I);
@ -493,46 +578,63 @@ end;
procedure InitInternational; procedure InitInternational;
var Country: TCountryCode; var
CtryInfo: TCountryInfo; Size: cardinal;
Size: cardinal; RC: cardinal;
RC: cardinal;
begin begin
Size := 0; Size := 0;
FillChar (Country, SizeOf (Country), 0); FillChar (Country, SizeOf (Country), 0);
FillChar (CtryInfo, SizeOf (CtryInfo), 0); FillChar (CtryInfo, SizeOf (CtryInfo), 0);
RC := DosQueryCtryInfo (SizeOf (CtryInfo), Country, CtryInfo, Size); RC := DosQueryCtryInfo (SizeOf (CtryInfo), Country, CtryInfo, Size);
if RC = 0 then if RC = 0 then
begin begin
DateSeparator := CtryInfo.DateSeparator; DateSeparator := CtryInfo.DateSeparator;
case CtryInfo.DateFormat of case CtryInfo.DateFormat of
1: begin 1: begin
ShortDateFormat := 'd/m/y'; ShortDateFormat := 'd/m/y';
LongDateFormat := 'dd" "mmmm" "yyyy'; LongDateFormat := 'dd" "mmmm" "yyyy';
end;
2: begin
ShortDateFormat := 'y/m/d';
LongDateFormat := 'yyyy" "mmmm" "dd';
end;
3: begin
ShortDateFormat := 'm/d/y';
LongDateFormat := 'mmmm" "dd" "yyyy';
end;
end;
TimeSeparator := CtryInfo.TimeSeparator;
DecimalSeparator := CtryInfo.DecimalSeparator;
ThousandSeparator := CtryInfo.ThousandSeparator;
CurrencyFormat := CtryInfo.CurrencyFormat;
CurrencyString := PChar (CtryInfo.CurrencyUnit);
end; end;
InitAnsi; 2: begin
InitInternationalGeneric; ShortDateFormat := 'y/m/d';
LongDateFormat := 'yyyy" "mmmm" "dd';
end;
3: begin
ShortDateFormat := 'm/d/y';
LongDateFormat := 'mmmm" "dd" "yyyy';
end;
end;
TimeSeparator := CtryInfo.TimeSeparator;
DecimalSeparator := CtryInfo.DecimalSeparator;
ThousandSeparator := CtryInfo.ThousandSeparator;
CurrencyFormat := CtryInfo.CurrencyFormat;
CurrencyString := PChar (CtryInfo.CurrencyUnit);
end
else
OSErrorWatch (RC);
InitAnsi;
InitInternationalGeneric;
end; end;
function SysErrorMessage(ErrorCode: Integer): String; function SysErrorMessage(ErrorCode: Integer): String;
const
SysMsgFile: array [0..10] of char = 'OSO001.MSG'#0;
var
OutBuf: array [0..999] of char;
RetMsgSize: cardinal;
RC: cardinal;
begin begin
Result:=Format(SUnknownErrorCode,[ErrorCode]); RC := DosGetMessage (nil, 0, @OutBuf [0], SizeOf (OutBuf),
ErrorCode, @SysMsgFile [0], RetMsgSize);
if RC = 0 then
begin
SetLength (Result, RetMsgSize);
Move (OutBuf [0], Result [1], RetMsgSize);
end
else
begin
Result:=Format(SUnknownErrorCode,[ErrorCode]);
OSErrorWatch (RC);
end;
end; end;
@ -687,7 +789,10 @@ begin
SD.ObjectBuffLen := ObjBufSize; SD.ObjectBuffLen := ObjBufSize;
RC := DosCreateQueue (HQ, quFIFO or quConvert_Address, @QName [1]); RC := DosCreateQueue (HQ, quFIFO or quConvert_Address, @QName [1]);
if RC <> 0 then if RC <> 0 then
Move (QName [1], ObjNameBuf^, Length (QName)) begin
Move (QName [1], ObjNameBuf^, Length (QName));
OSErrorWatch (RC);
end
else else
begin begin
RC := DosStartSession (SD, SID, PID); RC := DosStartSession (SD, SID, PID);
@ -697,15 +802,28 @@ begin
if RC = 0 then if RC = 0 then
begin begin
Result := PCI^.Return; Result := PCI^.Return;
DosCloseQueue (HQ); RC := DosCloseQueue (HQ);
DosFreeMem (PCI); if RC <> 0 then
OSErrorWatch (RC);
RC := DosFreeMem (PCI);
if RC <> 0 then
OSErrorWatch (RC);
FreeMem (ObjNameBuf, ObjBufSize); FreeMem (ObjNameBuf, ObjBufSize);
end end
else else
DosCloseQueue (HQ); begin
OSErrorWatch (RC);
RC := DosCloseQueue (HQ);
OSErrorWatch (RC);
end;
end end
else else
DosCloseQueue (HQ); begin
OSErrorWatch (RC);
RC := DosCloseQueue (HQ);
if RC <> 0 then
OSErrorWatch (RC);
end;
end; end;
end; end;
@ -715,52 +833,57 @@ begin
GetMem (ObjNameBuf, ObjBufSize); GetMem (ObjNameBuf, ObjBufSize);
FillChar (ObjNameBuf^, ObjBufSize, 0); FillChar (ObjNameBuf^, ObjBufSize, 0);
if (DosQueryAppType (PChar (Path), ExecAppType) = 0) and RC := DosQueryAppType (PChar (Path), ExecAppType);
(ApplicationType and 3 = ExecAppType and 3) then if RC <> 0 then
(* DosExecPgm should work... *)
begin begin
if ComLine = '' then OSErrorWatch (RC);
begin if (RC = 190) or (RC = 191) then
Args0 := nil; Result := StartSession;
Args := nil;
end
else
begin
GetMem (Args0, MaxArgsSize);
Args := Args0;
(* Work around a bug in OS/2 - argument to DosExecPgm *)
(* should not cross 64K boundary. *)
if ((PtrUInt (Args) + 1024) and $FFFF) < 1024 then
Inc (pointer (Args), 1024);
ArgSize := 0;
Move (Path [1], Args^ [ArgSize], Length (Path));
Inc (ArgSize, Length (Path));
Args^ [ArgSize] := 0;
Inc (ArgSize);
{Now do the real arguments.}
Move (ComLine [1], Args^ [ArgSize], Length (ComLine));
Inc (ArgSize, Length (ComLine));
Args^ [ArgSize] := 0;
Inc (ArgSize);
Args^ [ArgSize] := 0;
end;
Res.ExitCode := $FFFFFFFF;
RC := DosExecPgm (ObjNameBuf, ObjBufSize, 0, Args, nil, Res, PChar (Path));
if Args0 <> nil then
FreeMem (Args0, MaxArgsSize);
if RC = 0 then
begin
Result := Res.ExitCode;
FreeMem (ObjNameBuf, ObjBufSize);
end
else
begin
if (RC = 190) or (RC = 191) then
Result := StartSession;
end;
end end
else else
Result := StartSession; begin
if (ApplicationType and 3 = ExecAppType and 3) then
(* DosExecPgm should work... *)
begin
if ComLine = '' then
begin
Args0 := nil;
Args := nil;
end
else
begin
GetMem (Args0, MaxArgsSize);
Args := Args0;
(* Work around a bug in OS/2 - argument to DosExecPgm *)
(* should not cross 64K boundary. *)
if ((PtrUInt (Args) + 1024) and $FFFF) < 1024 then
Inc (pointer (Args), 1024);
ArgSize := 0;
Move (Path [1], Args^ [ArgSize], Length (Path));
Inc (ArgSize, Length (Path));
Args^ [ArgSize] := 0;
Inc (ArgSize);
{Now do the real arguments.}
Move (ComLine [1], Args^ [ArgSize], Length (ComLine));
Inc (ArgSize, Length (ComLine));
Args^ [ArgSize] := 0;
Inc (ArgSize);
Args^ [ArgSize] := 0;
end;
Res.ExitCode := $FFFFFFFF;
RC := DosExecPgm (ObjNameBuf, ObjBufSize, 0, Args, nil, Res,
PChar (Path));
if RC <> 0 then
OSErrorWatch (RC);
if Args0 <> nil then
FreeMem (Args0, MaxArgsSize);
if RC = 0 then
begin
Result := Res.ExitCode;
FreeMem (ObjNameBuf, ObjBufSize);
end
end
end;
if RC <> 0 then if RC <> 0 then
begin begin
ObjName := StrPas (ObjNameBuf); ObjName := StrPas (ObjNameBuf);
@ -805,16 +928,33 @@ begin
GetTickCount := L; GetTickCount := L;
end; end;
function GetTickCount64: QWord; function GetTickCount64: QWord;
var var
L: cardinal; Freq2: cardinal;
T: QWord;
begin begin
DosQuerySysInfo (svMsCount, svMsCount, L, 4); DosTmrQueryFreq (Freq2);
GetTickCount64 := L; DosTmrQueryTime (T);
GetTickCount64 := T div (QWord (Freq2) div 1000);
{$NOTE GetTickCount64 takes 20 microseconds on 1GHz CPU, GetTickCount not measurable}
end; end;
threadvar
LastOSError: cardinal;
const
OrigOSErrorWatch: TOSErrorWatch = nil;
procedure TrackLastOSError (Error: cardinal);
begin
LastOSError := Error;
OrigOSErrorWatch (Error);
end;
function GetLastOSError: Integer;
begin
GetLastOSError := Integer (LastOSError);
end;
{**************************************************************************** {****************************************************************************
Initialization code Initialization code
@ -824,6 +964,9 @@ Initialization
InitExceptions; { Initialize exceptions. OS independent } InitExceptions; { Initialize exceptions. OS independent }
InitInternational; { Initialize internationalization settings } InitInternational; { Initialize internationalization settings }
OnBeep:=@SysBeep; OnBeep:=@SysBeep;
LastOSError := 0;
OrigOSErrorWatch := OSErrorWatch;
SetOSErrorTracking (@TrackLastOSError);
Finalization Finalization
DoneExceptions; DoneExceptions;
end. end.

11
rtl/os2/tthread.inc
View File

@ -166,13 +166,16 @@ procedure TThread.SetPriority(Value: TThreadPriority);
var var
PTIB: PThreadInfoBlock; PTIB: PThreadInfoBlock;
PPIB: PProcessInfoBlock; PPIB: PProcessInfoBlock;
RC: cardinal;
begin begin
DosGetInfoBlocks (@PTIB, @PPIB); DosGetInfoBlocks (@PTIB, @PPIB);
(* (*
PTIB^.TIB2^.Priority := Priorities [Value]; PTIB^.TIB2^.Priority := Priorities [Value];
*) *)
DosSetPriority (2, High (Priorities [Value]), RC := DosSetPriority (2, High (Priorities [Value]),
Low (Priorities [Value]) - PTIB^.TIB2^.Priority, FHandle); Low (Priorities [Value]) - PTIB^.TIB2^.Priority, FHandle);
if RC <> 0 then
OSErrorWatch (RC);
end; end;
@ -213,9 +216,13 @@ end;
function TThread.WaitFor: Integer; function TThread.WaitFor: Integer;
var var
FH: cardinal; FH: cardinal;
RC: cardinal;
begin begin
if GetCurrentThreadID = MainThreadID then if GetCurrentThreadID = MainThreadID then
while not (FFinished) do while not (FFinished) do
CheckSynchronize (1000); CheckSynchronize (1000);
WaitFor := DosWaitThread (FH, dtWait); RC := DosWaitThread (FH, dtWait);
if RC <> 0 then
OSErrorWatch (RC);
WaitFor := RC;
end; end;