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

* error code fixes

Browse Source
This commit is contained in:
peter 2002-12-24 15:35:15 +00:00
parent f8bb808c3b
commit 5e80bcb7f8
2 changed files with 56 additions and 23 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

26
rtl/win32/dos.pp
View File

@ -583,6 +583,8 @@ begin
if not FindNextFile (F.FindHandle,F.W32FindData) then
begin
DosError:=Last2DosError(GetLastError);
if DosError=2 then
DosError:=18;
exit;
end;
end;
@ -607,6 +609,8 @@ begin
If longint(F.FindHandle)=Invalid_Handle_value then
begin
DosError:=Last2DosError(GetLastError);
if DosError=2 then
DosError:=18;
exit;
end;
{ Find file with correct attribute }
@ -621,6 +625,8 @@ begin
if not FindNextFile (F.FindHandle,F.W32FindData) then
begin
DosError:=Last2DosError(GetLastError);
if DosError=2 then
DosError:=18;
exit;
end;
{ Find file with correct attribute }
@ -812,11 +818,15 @@ procedure getftime(var f;var time : longint);
var
ft : TFileTime;
begin
doserror:=0;
if GetFileTime(filerec(f).Handle,nil,nil,@ft) and
WinToDosTime(ft,time) then
exit
else
time:=0;
begin
DosError:=Last2DosError(GetLastError);
time:=0;
end;
end;
@ -824,9 +834,12 @@ procedure setftime(var f;time : longint);
var
ft : TFileTime;
begin
if DosToWinTime(time,ft) then
if not SetFileTime(filerec(f).Handle,nil,nil,@ft) then;
DosError:=Last2DosError(GetLastError);
doserror:=0;
if DosToWinTime(time,ft) and
SetFileTime(filerec(f).Handle,nil,nil,@ft) then
exit
else
DosError:=Last2DosError(GetLastError);
end;
@ -1037,7 +1050,10 @@ begin
end.
{
$Log$
Revision 1.17 2002-12-15 20:23:53 peter
Revision 1.18 2002-12-24 15:35:15 peter
* error code fixes
Revision 1.17 2002/12/15 20:23:53 peter
* map error 87 to 13 to be compatible with dos
Revision 1.16 2002/12/04 21:35:50 carl

53
rtl/win32/system.pp
View File

@ -161,6 +161,8 @@ CONST
{ A pipe has been closed on the other end }
{ Removing that error allows eof to works as on other OSes }
ERROR_BROKEN_PIPE = 109;
ERROR_DIR_NOT_EMPTY = 145;
ERROR_ALREADY_EXISTS = 183;
{$IFDEF SUPPORT_THREADVAR}
threadvar
@ -188,21 +190,25 @@ var
Procedure Errno2InOutRes;
Begin
{ DO NOT MODIFY UNLESS YOU KNOW EXACTLY WHAT YOU ARE DOING }
if (errno >= ERROR_WRITE_PROTECT) and (errno <= ERROR_GEN_FAILURE) THEN
BEGIN
{ This is the offset to the Win32 to add to directly map }
{ to the DOS/TP compatible error codes when in this range }
InOutRes := word(errno)+131;
END
else
{ This case is special }
if errno=ERROR_SHARING_VIOLATION THEN
BEGIN
InOutRes :=5;
END
else
{ other error codes can directly be mapped }
InOutRes := Word(errno);
case Errno of
ERROR_WRITE_PROTECT..ERROR_GEN_FAILURE :
begin
{ This is the offset to the Win32 to add to directly map }
{ to the DOS/TP compatible error codes when in this range }
InOutRes := word(errno)+131;
end;
ERROR_DIR_NOT_EMPTY,
ERROR_ALREADY_EXISTS,
ERROR_SHARING_VIOLATION :
begin
InOutRes :=5;
end;
else
begin
{ other error codes can directly be mapped }
InOutRes := Word(errno);
end;
end;
errno:=0;
end;
@ -307,7 +313,8 @@ end;
external 'kernel32' name 'SetEndOfFile';
function GetFileType(Handle:DWORD):DWord;
external 'kernel32' name 'GetFileType';
function GetFileAttributes(p : pchar) : dword;
external 'kernel32' name 'GetFileAttributesA';
procedure AllowSlash(p:pchar);
var
@ -338,6 +345,11 @@ begin
if DeleteFile(p)=0 then
Begin
errno:=GetLastError;
if errno=5 then
begin
if (GetFileAttributes(p)=FILE_ATTRIBUTE_DIRECTORY) then
errno:=2;
end;
Errno2InoutRes;
end;
end;
@ -623,6 +635,8 @@ begin
If (s='') or (InOutRes <> 0) then
exit;
dirfn(TDirFnType(@SetCurrentDirectory),s);
if Inoutres=2 then
Inoutres:=3;
end;
procedure GetDir (DriveNr: byte; var Dir: ShortString);
@ -893,7 +907,7 @@ begin
{ call exitprocess, with cleanup as required }
asm
xorl %eax, %eax
movw exitcode,%ax
movw exitcode,%ax
call asm_exit
end;
end;
@ -1505,7 +1519,10 @@ end.
{
$Log$
Revision 1.38 2002-12-07 13:58:45 carl
Revision 1.39 2002-12-24 15:35:15 peter
* error code fixes
Revision 1.38 2002/12/07 13:58:45 carl
* fix warnings
Revision 1.37 2002/11/30 18:17:35 carl