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

* implement waitformultiple for win32 only.

Browse Source 
* Change interface to allow for COM waiting + a basic windows implementation. (only for desktop apps? Use msgwait* for the rest?)
This commit is contained in:
marcoonthegit 2023-05-20 14:37:03 +02:00
parent 31c225f6b5
commit 452ec93f06
12 changed files with 138 additions and 54 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

148
packages/fcl-base/src/syncobjs.pp
View File

@ -51,17 +51,26 @@ type
constructor Create;
destructor Destroy;override;
end;
THandleObject= class;
THandleObjectArray = array of THandleObject;
THandleObject = class abstract (TSynchroObject)
protected
FHandle : TEventHandle;
FLastError : Integer;
{$IFDEF MSWINDOWS}
// Windows specific, use COWait* functions for com compatibility.
FUseCOMWait: Boolean;
{$ENDIF MSWINDOWS}
public
constructor Create(UseComWait : Boolean=false);
destructor Destroy; override;
function WaitFor(Timeout : Cardinal=INFINITE) : TWaitResult;
{$IFDEF MSWINDOWS}
class function WaitForMultiple(const HandleObjs: THandleObjectArray; Timeout: Cardinal; AAll: Boolean; out SignaledObj: THandleObject; UseCOMWait: Boolean = False; Len: Integer = 0): TWaitResult;
{$ENDIF MSWINDOWS}
property Handle : TEventHandle read FHandle;
property LastError : Integer read FLastError;
end;
THandleObjectArray = array of THandleObject;
TEventObject = class(THandleObject)
private
@ -69,12 +78,10 @@ type
public
constructor Create(EventAttributes : PSecurityAttributes;
AManualReset,InitialState : Boolean;const Name : string;
UseComWait:boolean=false);
constructor Create(UseComWait : Boolean=false);
destructor Destroy; override;
UseComWait:boolean=false); overload;
procedure ResetEvent;
procedure SetEvent;
function WaitFor(Timeout : Cardinal=INFINITE) : TWaitResult;
Property ManualReset : Boolean read FManualReset;
end;
@ -86,8 +93,18 @@ type
implementation
{$ifdef MSWindows}
uses Windows;
function CoWaitForMultipleObjects(nCount:DWORD; lpHandles : PWOHandleArray; bWaitAll:WINBOOL; dwMilliseconds:DWORD):DWORD; external 'kernel32' name 'CoWaitForMultipleObjects';
{$endif}
Resourcestring
SErrEventCreateFailed = 'Failed to create OS basic event with name "%s"';
SErrEventCreateFailed = 'Failed to create OS basic event with name "%s"';
SErrEventZeroNotAllowed = 'Handle count of zero is not allowed.';
SErrEventMaxObjects = 'The maximal amount of objects is %d.';
SErrEventTooManyHandles = 'Length of object handles smaller than Len.';
{ ---------------------------------------------------------------------
Real syncobjs implementation
@ -122,7 +139,7 @@ end;
function TCriticalSection.TryEnter:boolean;
begin
result:=TryEnterCriticalSection(CriticalSection)<>0;
result:=System.TryEnterCriticalSection(CriticalSection)<>0;
end;
procedure TCriticalSection.Acquire;
@ -150,34 +167,104 @@ begin
DoneCriticalSection(CriticalSection);
end;
destructor THandleObject.destroy;
{ THandleObject }
constructor THandleObject.Create(UseComWait : Boolean=false);
// cmompatibility shortcut constructor, Com waiting not implemented yet
begin
FHandle := BasicEventCreate(nil, True,False,'');
if (FHandle=Nil) then
Raise ESyncObjectException.CreateFmt(SErrEventCreateFailed,['']);
end;
function THandleObject.WaitFor(Timeout : Cardinal) : TWaitResult;
begin
Result := TWaitResult(basiceventWaitFor(Timeout, Handle));
if Result = wrError then
{$IFDEF OS2}
FLastError := PLocalEventRec (Handle)^.FLastError;
{$ELSE OS2}
{$if declared(getlastoserror)}
FLastError := GetLastOSError;
{$else}
FLastError:=-1;
{$endif}
{$ENDIF OS2}
end;
{$IFDEF MSWINDOWS}
class function THandleObject.WaitForMultiple(const HandleObjs: THandleObjectArray; Timeout: Cardinal; AAll: Boolean; out SignaledObj: THandleObject; UseCOMWait: Boolean = False; Len: Integer = 0): TWaitResult;
var
ret: Integer;
AmountHandles: Integer;
begin
AmountHandles := Length(HandleObjs);
if AmountHandles = 0 then
raise ESyncObjectException.Create(SErrEventZeroNotAllowed);
if AmountHandles > MAXIMUM_WAIT_OBJECTS then
raise ESyncObjectException.CreateFmt(SErrEventMaxObjects, [MAXIMUM_WAIT_OBJECTS]);
if Len > AmountHandles then
raise ESyncObjectException.Create(SErrEventTooManyHandles);
// what about UseCOMWait?
{$IFDEF MSWINDOWS}
if UseCOMWait Then
begin
SetLastError(ERROR_SUCCESS); // only for "alertable" objects
ret := CoWaitForMultipleObjects(Len, @HandleObjs, AAll, Timeout);
end
else
{$ENDIF}
ret := WaitForMultipleObjects(Len, @HandleObjs, AAll, Timeout);
if (ret >= WAIT_OBJECT_0) and (ret < (WAIT_OBJECT_0 + Len)) then
begin
if not AAll then
SignaledObj := HandleObjs[ret];
Exit(wrSignaled);
end;
if (ret >= WAIT_ABANDONED_0) and (ret < (WAIT_ABANDONED_0 + Len)) then
begin
if not AAll then
SignaledObj := HandleObjs[ret];
Exit(wrAbandoned);
end;
case ret of
WAIT_TIMEOUT:
begin
Result := wrTimeout;
end;
Integer(WAIT_FAILED): // w/o: Warning: Range check error while evaluating constants (4294967295 must be between -2147483648 and 2147483647)
begin
Result := wrError;
end;
end;
end;
{$endif}
destructor THandleObject.Destroy;
begin
BasicEventDestroy(Handle);
end;
constructor TEventObject.Create(EventAttributes : PSecurityAttributes;
AManualReset,InitialState : Boolean;const Name : string;UseComWait:boolean=false);
begin
{$IFDEF MSWINDOWS}
FUseCOMWait:=UseComWait;
{$endif}
FHandle := BasicEventCreate(EventAttributes, AManualReset, InitialState, Name);
if (FHandle=Nil) then
Raise ESyncObjectException.CreateFmt(SErrEventCreateFailed,[Name]);
FManualReset:=AManualReset;
end;
constructor TEventObject.Create(UseComWait : Boolean=false);
// cmompatibility shortcut constructor, Com waiting not implemented yet
begin
Create(nil,True,false,'',UseComWait);
end;
destructor TEventObject.destroy;
begin
BasicEventDestroy(Handle);
end;
procedure TEventObject.ResetEvent;
begin
@ -190,23 +277,6 @@ begin
BasicEventSetEvent(Handle);
end;
function TEventObject.WaitFor(Timeout : Cardinal) : TWaitResult;
begin
Result := TWaitResult(basiceventWaitFor(Timeout, Handle));
if Result = wrError then
{$IFDEF OS2}
FLastError := PLocalEventRec (Handle)^.FLastError;
{$ELSE OS2}
{$if defined(getlastoserror)}
FLastError := GetLastOSError;
{$else}
FLastError:=-1;
{$endif}
{$ENDIF OS2}
end;
constructor TSimpleEvent.Create;
begin

2
rtl/amicommon/athreads.pp
View File

@ -1117,7 +1117,7 @@ end;
// End timer stuff
// the mighty Waitfor routine
function intbasiceventWaitFor(Timeout : Cardinal;state:peventstate) : longint;
function intbasiceventWaitFor(Timeout : Cardinal;state:peventstate;FUseComWait : Boolean=False) : longint;
var
AmiEvent: PAmiEvent absolute State;
Tr: PTimeRequest = nil;

2
rtl/beos/bethreads.pp
View File

@ -463,7 +463,7 @@ begin
end;
end;
function IntbasiceventWaitFor(Timeout : Cardinal;state:peventstate) : longint;
function IntbasiceventWaitFor(Timeout : Cardinal;state:peventstate;FUseComWait : Boolean=False) : longint;
begin
If TimeOut<>Cardinal($FFFFFFFF) then

6
rtl/inc/thread.inc
View File

@ -305,10 +305,10 @@ begin
currenttm.BasicEventSetEvent(state);
end;
function BasicEventWaitFor(Timeout : Cardinal;state:peventstate) : longint;
function BasicEventWaitFor(Timeout : Cardinal;state:peventstate;FUseComWait : Boolean=False) : longint;
begin
result:=currenttm.BasicEventWaitFor(Timeout,state);
result:=currenttm.BasicEventWaitFor(Timeout,state,FUseComWait);
end;
function RTLEventCreate :PRTLEvent;
@ -542,7 +542,7 @@ begin
ThreadingAlreadyUsed:=true;
end;
function NoBasicEventWaitFor(Timeout : Cardinal;state:peventstate) : longint;
function NoBasicEventWaitFor(Timeout : Cardinal;state:peventstate;FUseComWait : Boolean=False) : longint;
begin
if IsMultiThread then

4
rtl/inc/threadh.inc
View File

@ -56,7 +56,7 @@ type
TAllocateThreadVarsHandler = Procedure;
TReleaseThreadVarsHandler = Procedure;
TBasicEventHandler = procedure(state:peventstate);
TBasicEventWaitForHandler = function (timeout:cardinal;state:peventstate):longint;
TBasicEventWaitForHandler = function (timeout:cardinal;state:peventstate;FUseComWait : Boolean=False):longint;
TBasicEventCreateHandler = function (EventAttributes :Pointer; AManualReset,InitialState : Boolean;const Name:ansistring):pEventState;
TRTLEventHandler = procedure(AEvent:PRTLEvent);
TRTLEventHandlerTimeout = procedure(AEvent:PRTLEvent;timeout : longint);
@ -174,7 +174,7 @@ function BasicEventCreate(EventAttributes : Pointer; AManualReset,InitialState
procedure BasicEventDestroy(state:peventstate);
procedure BasicEventResetEvent(state:peventstate);
procedure BasicEventSetEvent(state:peventstate);
function BasicEventWaitFor(Timeout : Cardinal;state:peventstate) : longint;
function BasicEventWaitFor(Timeout : Cardinal;state:peventstate;FUseComWait : Boolean=False) : longint;
function RTLEventCreate :PRTLEvent;
procedure RTLEventDestroy(state:pRTLEvent);

2
rtl/nativent/systhrd.inc
View File

@ -188,7 +188,7 @@ procedure intbasiceventSetEvent(state:peventstate);
begin
end;
function intbasiceventWaitFor(Timeout : Cardinal;state:peventstate) : longint;
function intbasiceventWaitFor(Timeout : Cardinal;state:peventstate;FUseComWait : Boolean=False) : longint;
begin
Result := STATUS_NOT_IMPLEMENTED;
end;

2
rtl/netware/systhrd.inc
View File

@ -420,7 +420,7 @@ begin
{$WARNING TODO! intbasiceventSetEvent}
end;
function intbasiceventWaitFor(Timeout : Cardinal;state:peventstate) : longint;
function intbasiceventWaitFor(Timeout : Cardinal;state:peventstate;FUseComWait : Boolean=False) : longint;
begin
{$WARNING TODO! intbasiceventWaitFor}
end;

2
rtl/netwlibc/systhrd.inc
View File

@ -333,7 +333,7 @@ begin
end;
end;
function IntbasiceventWaitFor(Timeout : Cardinal;state:peventstate) : longint;
function IntbasiceventWaitFor(Timeout : Cardinal;state:peventstate;FUseComWait : Boolean=False) : longint;
begin
If TimeOut<>Cardinal($FFFFFFFF) then

2
rtl/os2/systhrd.inc
View File

@ -833,7 +833,7 @@ begin
end;
function SysBasicEventWaitFor (Timeout: Cardinal; State: PEventState): longint;
function SysBasicEventWaitFor (Timeout: Cardinal; State: PEventState;FUseComWait : Boolean=False): longint;
var
RC: cardinal;
begin

2
rtl/unix/cthreads.pp
View File

@ -809,7 +809,7 @@ begin
pthread_mutex_unlock(@plocaleventstate(state)^.feventsection);
end;
function IntbasiceventWaitFor(Timeout : Cardinal;state:peventstate) : longint;
function IntbasiceventWaitFor(Timeout : Cardinal;state:peventstate;FUseComWait : Boolean=False) : longint;
var
timespec: ttimespec;
errres: cint;

2
rtl/wasi/systhrd.inc
View File

@ -162,7 +162,7 @@ begin
{todo:implement}
end;
function WasiBasicEventWaitFor(timeout:cardinal;state:peventstate):longint;
function WasiBasicEventWaitFor(timeout:cardinal;state:peventstate;FUseComWait : Boolean=False):longint;
begin
{todo:implement}
end;

18
rtl/win/systhrd.inc
View File

@ -329,7 +329,9 @@ var
function SysWaitForThreadTerminate (threadHandle : TThreadID; TimeoutMs : longint) : dword;
begin
// shouldn't this be a msgwait in case the thread creates "Windows" See comment in waitforsingle?
if timeoutMs = 0 then dec (timeoutMs); // $ffffffff is INFINITE
// does waiting on thread require cowait too ?
SysWaitForThreadTerminate := WaitForSingleObject(threadHandle, TimeoutMs);
end;
@ -539,10 +541,22 @@ begin
SetEvent(THandle(state));
end;
function intbasiceventWaitFor(Timeout : Cardinal;state:peventstate) : longint;
type
PWOHandleArray = ^THandle;
function CoWaitForMultipleObjects(nCount:DWORD; lpHandles : PWOHandleArray; bWaitAll:LONGBOOL; dwMilliseconds:DWORD):DWORD; external 'ole32.dll' name 'CoWaitForMultipleObjects';
function intbasiceventWaitFor(Timeout : Cardinal;state:peventstate;UseCOMWait: Boolean = False) : longint;
var ret : Integer;
begin
case WaitForSingleObject(THandle(state), Timeout) of
if UseComWait Then
ret:=CoWaitForMultipleObjects(1,PWOHandleArray(@state), True, Timeout)
else
ret:=WaitForSingleObject(THandle(state), Timeout);
case ret of
WAIT_ABANDONED: Result := wrAbandoned;
WAIT_OBJECT_0: Result := wrSignaled;
WAIT_TIMEOUT: Result := wrTimeout;