client/3.0/FB30Events.pas

(*
 *  Firebird Interface (fbintf). The fbintf components provide a set of
 *  Pascal language bindings for the Firebird API.
 *
 *  The contents of this file are subject to the Initial Developer's
 *  Public License Version 1.0 (the "License"); you may not use this
 *  file except in compliance with the License. You may obtain a copy
 *  of the License here:
 *
 *    http://www.firebirdsql.org/index.php?op=doc&id=idpl
 *
 *  Software distributed under the License is distributed on an "AS
 *  IS" basis, WITHOUT WARRANTY OF ANY KIND, either express or
 *  implied. See the License for the specific language governing rights
 *  and limitations under the License.
 *
 *  The Initial Developer of the Original Code is Tony Whyman.
 *
 *  The Original Code is (C) 2016 Tony Whyman, MWA Software
 *  (http://www.mwasoftware.co.uk).
 *
 *  All Rights Reserved.
 *
 *  Contributor(s): ______________________________________.
 *
*)
unit FB30Events;
{$IFDEF MSWINDOWS} 
{$DEFINE WINDOWS} 
{$ENDIF}

{$IFDEF FPC}
{$mode delphi}
{$interfaces COM}
{$ENDIF}

{ $DEFINE EVENTDEBUG}

interface

uses
  {$IFDEF WINDOWS}Windows, {$ENDIF} Classes, SysUtils, Firebird, IB, FB30ClientAPI, FB30Attachment,
  syncobjs, FBEvents;

type
  TFB30Events = class;

  { TEventhandlerInterface }

  TEventhandlerInterface = class(Firebird.IEventCallbackImpl)
  private
    FOwner: TFB30Events;
    FName: AnsiString;
    FRef: integer;
    {$IFDEF WINDOWS}
    {Make direct use of Windows API as TEventObject don't seem to work under
     Windows!}
    FEventHandler: THandle;
    {$ELSE}
    FEventWaiting: TEventObject;
    {$ENDIF}
  public
    constructor Create(aOwner: TFB30Events; aName: AnsiString);
    destructor Destroy; override;
    procedure addRef();  override;
    function release(): Integer; override;
    procedure eventCallbackFunction(length: Cardinal; events: BytePtr); override;
    procedure WaitForEvent;
    procedure CancelWait;
 end;

  { TFB30Events }

  TFB30Events = class(TFBEvents,IEvents)
  private
    FAttachmentIntf: Firebird.IAttachment;
    FEventHandlerThread: TObject;
    FEventsIntf: Firebird.IEvents;
    FAsyncEventCallback: TEventhandlerInterface;
    FSyncEventCallback: TEventhandlerInterface;
    FFirebird30ClientAPI: TFB30ClientAPI;
    procedure InternalAsyncWaitForEvent(EventHandler: TEventHandler; EventCallBack: TEventhandlerInterface);
    procedure ReleaseIntf;
  protected
    procedure CancelEvents(Force: boolean = false); override;
    function GetIEvents: IEvents; override;
  public
    constructor Create(DBAttachment: TFB30Attachment; Events: TStrings);
    destructor Destroy; override;

    {IEvents}
    procedure WaitForEvent;
    procedure AsyncWaitForEvent(EventHandler: TEventHandler); override;
  end;

implementation

uses  FBMessages, FBClientAPI;

type
  { TEventHandlerThread }

  TEventHandlerThread = class(TThread)
  private
    FOwner: TFB30Events;
    FEventHandler: TEventhandlerInterface;
  protected
    procedure Execute; override;
  public
    constructor Create(Owner: TFB30Events; EventHandler: TEventhandlerInterface);
    procedure Terminate;
  end;

constructor TEventhandlerInterface.Create(aOwner: TFB30Events; aName: AnsiString);
var
  PSa : PSecurityAttributes;
{$IFDEF WINDOWS}
  Sd : TSecurityDescriptor;
  Sa : TSecurityAttributes;
begin
  InitializeSecurityDescriptor(@Sd,SECURITY_DESCRIPTOR_REVISION);
  SetSecurityDescriptorDacl(@Sd,true,nil,false);
  Sa.nLength := SizeOf(Sa);
  Sa.lpSecurityDescriptor := @Sd;
  Sa.bInheritHandle := true;
  PSa := @Sa;
{$ELSE}
  GUID : TGUID;
begin
  PSa:= nil;
{$ENDIF}
  inherited Create;
{$IFDEF WINDOWS}
  FEventHandler := CreateEvent(PSa,false,false,nil);
{$ELSE}
  CreateGuid(GUID);
  FEventWaiting := TEventObject.Create(PSa,false,false,GUIDToString(GUID));
{$ENDIF}
  FOWner := aOwner;
  FName := aName;
  addRef;
  {$IFDEF EVENTDEBUG} writeln(FName,' TEventhandlerInterface: Create'); {$ENDIF}
end;

destructor TEventhandlerInterface.Destroy;
begin
{$IFDEF WINDOWS}
  CloseHandle(FEventHandler);
{$ELSE}
  if assigned(FEventWaiting) then FEventWaiting.Free;
{$ENDIF}
{$IFDEF EVENTDEBUG} writeln(FName,' TEventhandlerInterface: Destroy'); {$ENDIF}
  inherited Destroy;
end;

procedure TEventhandlerInterface.addRef;
begin
  Inc(FRef);
{$IFDEF EVENTDEBUG}  writeln(FName,': ref count = ',FRef);{$ENDIF}
end;

function TEventhandlerInterface.release: Integer;
begin
  Dec(FRef);
{$IFDEF EVENTDEBUG}  writeln(FName,': ref count = ',FRef);{$ENDIF}
  if FRef = 0 then Free;
  Result := FRef;
end;

procedure TEventhandlerInterface.eventCallbackFunction(length: Cardinal;
  events: BytePtr);
begin
{$IFDEF EVENTDEBUG}  writeln(FName,' TEventhandlerInterface: Event Callback'); {$ENDIF}
  FOwner.FCriticalSection.Enter;
  try
    if FOwner.FResultBuffer <> nil then
      Move(events^, FOwner.FResultBuffer^, Length);
  finally
    FOwner.FCriticalSection.Leave
  end;
  {$IFDEF EVENTDEBUG}writeln(FName,' TEventhandlerInterface: Set Event Called'); {$ENDIF}
  {$IFDEF WINDOWS}
  SetEvent(FEventHandler);
  {$ELSE}
  FEventWaiting.SetEvent;
  {$ENDIF}
end;

procedure TEventhandlerInterface.WaitForEvent;
begin
{$IFDEF EVENTDEBUG}  writeln(FName,' TEventhandlerInterface: Start Event Wait'); {$ENDIF}
  {$IFDEF WINDOWS}
  WaitForSingleObject(FEventHandler,INFINITE);
  {$ELSE}
  FEventWaiting.WaitFor(INFINITE);
  {$ENDIF}
{$IFDEF EVENTDEBUG}  writeln(FName,' TEventhandlerInterface: Event Wait Ends');{$ENDIF}
end;

procedure TEventhandlerInterface.CancelWait;
begin
  {$IFDEF WINDOWS}
    SetEvent(FEventHandler);
  {$ELSE}
    FEventWaiting.SetEvent;
  {$ENDIF}
end;

 { TEventHandlerThread }

procedure TEventHandlerThread.Execute;
begin
  {$IFDEF EVENTDEBUG}  writeln('Event Handler Thread Starts'); {$ENDIF}
  while not Terminated do
  begin
    FEventHandler.WaitForEvent;
    {$IFDEF EVENTDEBUG}  writeln('Event Handler Ends Wait ',Terminated); {$ENDIF}

    if not Terminated  then
      FOwner.EventSignaled;
  end;
  {$IFDEF EVENTDEBUG}  writeln('Event Handler Thread Ends'); {$ENDIF}
end;

constructor TEventHandlerThread.Create(Owner: TFB30Events;
  EventHandler: TEventhandlerInterface);
begin
  inherited Create(false);
  FOwner := Owner;
  FEventHandler := EventHandler;
  FreeOnTerminate := true;
end;

procedure TEventHandlerThread.Terminate;
begin
  inherited Terminate;
  FEventHandler.CancelWait;
  {$IFDEF EVENTDEBUG}  writeln('Event Handler Thread Cancelled'); {$ENDIF}
end;

  { TFB30Events }

procedure TFB30Events.CancelEvents(Force: boolean);
begin
  FCriticalSection.Enter;
  try
    if not FInWaitState then Exit;
    if FEventsIntf <> nil then
    with FFirebird30ClientAPI do
    begin
      FEventsIntf.Cancel(StatusIntf);
      if not Force then
        Check4DataBaseError;
    end;
    FInWaitState := false;
    ReleaseIntf;
    inherited CancelEvents(Force);
  finally
    FCriticalSection.Leave
  end;
end;

function TFB30Events.GetIEvents: IEvents;
begin
  Result := self;
end;

procedure TFB30Events.InternalAsyncWaitForEvent(EventHandler: TEventHandler;
  EventCallBack: TEventhandlerInterface);
begin
  FCriticalSection.Enter;
  try
    if FInWaitState then
      IBError(ibxeInEventWait,[nil]);

    FEventHandler := EventHandler;
    ReleaseIntf;
    with FFirebird30ClientAPI do
    begin
      FEventsIntf := FAttachmentIntf.queEvents(
                                StatusIntf,EventCallBack,
                                FEventBufferLen, BytePtr(FEventBuffer));
      Check4DataBaseError;
    end;
    FInWaitState := true;

  finally
    FCriticalSection.Leave
  end;
end;

procedure TFB30Events.ReleaseIntf;
begin
  if FEventsIntf <> nil then
    FEventsIntf.release;
  FEventsIntf := nil;
end;

constructor TFB30Events.Create(DBAttachment: TFB30Attachment; Events: TStrings);
begin
  inherited Create(DBAttachment,DBAttachment,Events);
  FAttachmentIntf := DBAttachment.AttachmentIntf;
  FFirebird30ClientAPI := DBAttachment.Firebird30ClientAPI;
  FSyncEventCallback := TEventhandlerInterface.Create(self,'Sync');
end;

destructor TFB30Events.Destroy;
begin
  CancelEvents(true);
  if assigned(FEventHandlerThread) then
    TEventHandlerThread(FEventHandlerThread).Terminate;
  if assigned(FAsyncEventCallback) then TEventhandlerInterface(FAsyncEventCallback).release;
  if assigned(FSyncEventCallback) then TEventhandlerInterface(FSyncEventCallback).release;
  ReleaseIntf;
  inherited Destroy;
end;

procedure TFB30Events.AsyncWaitForEvent(EventHandler: TEventHandler);
begin
  {Seems like we have to create a new callback object each time to avoid empty events}
  if assigned(FEventHandlerThread) then
    TEventHandlerThread(FEventHandlerThread).Terminate;
  if assigned(FAsyncEventCallback) then TEventhandlerInterface(FAsyncEventCallback).release;
  FAsyncEventCallback := TEventhandlerInterface.Create(self,'Async');
  FEventHandlerThread := TEventHandlerThread.Create(self,FAsyncEventCallback);
  InternalAsyncWaitForEvent(EventHandler,FAsyncEventCallback);
end;

procedure TFB30Events.WaitForEvent;
begin
  InternalAsyncWaitForEvent(nil,FSyncEventCallback);
  FSyncEventCallback.WaitForEvent;
end;

end.

Revision:	362
Committed:	Tue Dec 7 13:27:39 2021 UTC (2 years, 11 months ago) by tony
Content type:	text/x-pascal
Original Path:	*ibx/branches/journaling/fbintf/client/3.0/FB30Events.pas*
File size:	9084 byte(s)
Log Message:	initiate test release
#	User	Rev	Content
1	tony	45	(*
2			* Firebird Interface (fbintf). The fbintf components provide a set of
3			* Pascal language bindings for the Firebird API.
4			*
5			* The contents of this file are subject to the Initial Developer's
6			* Public License Version 1.0 (the "License"); you may not use this
7			* file except in compliance with the License. You may obtain a copy
8			* of the License here:
9			*
10			* http://www.firebirdsql.org/index.php?op=doc&id=idpl
11			*
12			* Software distributed under the License is distributed on an "AS
13			* IS" basis, WITHOUT WARRANTY OF ANY KIND, either express or
14			* implied. See the License for the specific language governing rights
15			* and limitations under the License.
16			*
17			* The Initial Developer of the Original Code is Tony Whyman.
18			*
19			* The Original Code is (C) 2016 Tony Whyman, MWA Software
20			* (http://www.mwasoftware.co.uk).
21			*
22			* All Rights Reserved.
23			*
24			* Contributor(s): ______________________________________.
25			*
26			*)
27			unit FB30Events;
28	tony	56	{$IFDEF MSWINDOWS}
29			{$DEFINE WINDOWS}
30			{$ENDIF}
31	tony	45
32			{$IFDEF FPC}
33	tony	56	{$mode delphi}
34	tony	45	{$interfaces COM}
35			{$ENDIF}
36
37	tony	217	{ $DEFINE EVENTDEBUG}
38
39	tony	45	interface
40
41			uses
42			{$IFDEF WINDOWS}Windows, {$ENDIF} Classes, SysUtils, Firebird, IB, FB30ClientAPI, FB30Attachment,
43	tony	216	syncobjs, FBEvents;
44	tony	45
45			type
46			TFB30Events = class;
47
48			{ TEventhandlerInterface }
49
50			TEventhandlerInterface = class(Firebird.IEventCallbackImpl)
51			private
52			FOwner: TFB30Events;
53	tony	56	FName: AnsiString;
54	tony	45	FRef: integer;
55			{$IFDEF WINDOWS}
56			{Make direct use of Windows API as TEventObject don't seem to work under
57			Windows!}
58			FEventHandler: THandle;
59			{$ELSE}
60			FEventWaiting: TEventObject;
61			{$ENDIF}
62			public
63	tony	56	constructor Create(aOwner: TFB30Events; aName: AnsiString);
64	tony	45	destructor Destroy; override;
65			procedure addRef(); override;
66			function release(): Integer; override;
67			procedure eventCallbackFunction(length: Cardinal; events: BytePtr); override;
68			procedure WaitForEvent;
69			procedure CancelWait;
70			end;
71
72			{ TFB30Events }
73
74			TFB30Events = class(TFBEvents,IEvents)
75			private
76			FAttachmentIntf: Firebird.IAttachment;
77			FEventHandlerThread: TObject;
78			FEventsIntf: Firebird.IEvents;
79			FAsyncEventCallback: TEventhandlerInterface;
80			FSyncEventCallback: TEventhandlerInterface;
81	tony	263	FFirebird30ClientAPI: TFB30ClientAPI;
82	tony	45	procedure InternalAsyncWaitForEvent(EventHandler: TEventHandler; EventCallBack: TEventhandlerInterface);
83			procedure ReleaseIntf;
84			protected
85			procedure CancelEvents(Force: boolean = false); override;
86			function GetIEvents: IEvents; override;
87			public
88			constructor Create(DBAttachment: TFB30Attachment; Events: TStrings);
89			destructor Destroy; override;
90
91			{IEvents}
92			procedure WaitForEvent;
93	tony	47	procedure AsyncWaitForEvent(EventHandler: TEventHandler); override;
94	tony	45	end;
95
96			implementation
97
98			uses FBMessages, FBClientAPI;
99
100			type
101			{ TEventHandlerThread }
102
103			TEventHandlerThread = class(TThread)
104			private
105			FOwner: TFB30Events;
106			FEventHandler: TEventhandlerInterface;
107			protected
108			procedure Execute; override;
109			public
110			constructor Create(Owner: TFB30Events; EventHandler: TEventhandlerInterface);
111			procedure Terminate;
112			end;
113
114	tony	56	constructor TEventhandlerInterface.Create(aOwner: TFB30Events; aName: AnsiString);
115	tony	45	var
116			PSa : PSecurityAttributes;
117			{$IFDEF WINDOWS}
118			Sd : TSecurityDescriptor;
119			Sa : TSecurityAttributes;
120			begin
121			InitializeSecurityDescriptor(@Sd,SECURITY_DESCRIPTOR_REVISION);
122			SetSecurityDescriptorDacl(@Sd,true,nil,false);
123			Sa.nLength := SizeOf(Sa);
124			Sa.lpSecurityDescriptor := @Sd;
125			Sa.bInheritHandle := true;
126			PSa := @Sa;
127			{$ELSE}
128			GUID : TGUID;
129			begin
130			PSa:= nil;
131			{$ENDIF}
132			inherited Create;
133			{$IFDEF WINDOWS}
134	tony	47	FEventHandler := CreateEvent(PSa,false,false,nil);
135	tony	45	{$ELSE}
136			CreateGuid(GUID);
137			FEventWaiting := TEventObject.Create(PSa,false,false,GUIDToString(GUID));
138			{$ENDIF}
139			FOWner := aOwner;
140			FName := aName;
141			addRef;
142	tony	217	{$IFDEF EVENTDEBUG} writeln(FName,' TEventhandlerInterface: Create'); {$ENDIF}
143	tony	45	end;
144
145			destructor TEventhandlerInterface.Destroy;
146			begin
147			{$IFDEF WINDOWS}
148			CloseHandle(FEventHandler);
149			{$ELSE}
150			if assigned(FEventWaiting) then FEventWaiting.Free;
151			{$ENDIF}
152	tony	217	{$IFDEF EVENTDEBUG} writeln(FName,' TEventhandlerInterface: Destroy'); {$ENDIF}
153	tony	45	inherited Destroy;
154			end;
155
156			procedure TEventhandlerInterface.addRef;
157			begin
158			Inc(FRef);
159	tony	217	{$IFDEF EVENTDEBUG} writeln(FName,': ref count = ',FRef);{$ENDIF}
160	tony	45	end;
161
162			function TEventhandlerInterface.release: Integer;
163			begin
164			Dec(FRef);
165	tony	217	{$IFDEF EVENTDEBUG} writeln(FName,': ref count = ',FRef);{$ENDIF}
166	tony	45	if FRef = 0 then Free;
167			Result := FRef;
168			end;
169
170			procedure TEventhandlerInterface.eventCallbackFunction(length: Cardinal;
171			events: BytePtr);
172			begin
173	tony	217	{$IFDEF EVENTDEBUG} writeln(FName,' TEventhandlerInterface: Event Callback'); {$ENDIF}
174	tony	45	FOwner.FCriticalSection.Enter;
175			try
176			if FOwner.FResultBuffer <> nil then
177	tony	56	Move(events^, FOwner.FResultBuffer^, Length);
178	tony	45	finally
179			FOwner.FCriticalSection.Leave
180			end;
181	tony	217	{$IFDEF EVENTDEBUG}writeln(FName,' TEventhandlerInterface: Set Event Called'); {$ENDIF}
182	tony	47	{$IFDEF WINDOWS}
183			SetEvent(FEventHandler);
184			{$ELSE}
185			FEventWaiting.SetEvent;
186			{$ENDIF}
187	tony	45	end;
188
189			procedure TEventhandlerInterface.WaitForEvent;
190			begin
191	tony	217	{$IFDEF EVENTDEBUG} writeln(FName,' TEventhandlerInterface: Start Event Wait'); {$ENDIF}
192	tony	45	{$IFDEF WINDOWS}
193			WaitForSingleObject(FEventHandler,INFINITE);
194			{$ELSE}
195			FEventWaiting.WaitFor(INFINITE);
196			{$ENDIF}
197	tony	217	{$IFDEF EVENTDEBUG} writeln(FName,' TEventhandlerInterface: Event Wait Ends');{$ENDIF}
198	tony	45	end;
199
200			procedure TEventhandlerInterface.CancelWait;
201			begin
202			{$IFDEF WINDOWS}
203			SetEvent(FEventHandler);
204			{$ELSE}
205			FEventWaiting.SetEvent;
206			{$ENDIF}
207			end;
208
209			{ TEventHandlerThread }
210
211			procedure TEventHandlerThread.Execute;
212			begin
213	tony	217	{$IFDEF EVENTDEBUG} writeln('Event Handler Thread Starts'); {$ENDIF}
214	tony	45	while not Terminated do
215			begin
216			FEventHandler.WaitForEvent;
217	tony	217	{$IFDEF EVENTDEBUG} writeln('Event Handler Ends Wait ',Terminated); {$ENDIF}
218	tony	45
219			if not Terminated then
220			FOwner.EventSignaled;
221			end;
222	tony	217	{$IFDEF EVENTDEBUG} writeln('Event Handler Thread Ends'); {$ENDIF}
223	tony	45	end;
224
225			constructor TEventHandlerThread.Create(Owner: TFB30Events;
226			EventHandler: TEventhandlerInterface);
227			begin
228	tony	56	inherited Create(false);
229	tony	45	FOwner := Owner;
230			FEventHandler := EventHandler;
231			FreeOnTerminate := true;
232			end;
233
234			procedure TEventHandlerThread.Terminate;
235			begin
236			inherited Terminate;
237			FEventHandler.CancelWait;
238	tony	217	{$IFDEF EVENTDEBUG} writeln('Event Handler Thread Cancelled'); {$ENDIF}
239	tony	45	end;
240
241			{ TFB30Events }
242
243			procedure TFB30Events.CancelEvents(Force: boolean);
244			begin
245			FCriticalSection.Enter;
246			try
247			if not FInWaitState then Exit;
248			if FEventsIntf <> nil then
249	tony	263	with FFirebird30ClientAPI do
250	tony	45	begin
251			FEventsIntf.Cancel(StatusIntf);
252			if not Force then
253			Check4DataBaseError;
254			end;
255			FInWaitState := false;
256			ReleaseIntf;
257			inherited CancelEvents(Force);
258			finally
259			FCriticalSection.Leave
260			end;
261			end;
262
263			function TFB30Events.GetIEvents: IEvents;
264			begin
265			Result := self;
266			end;
267
268			procedure TFB30Events.InternalAsyncWaitForEvent(EventHandler: TEventHandler;
269			EventCallBack: TEventhandlerInterface);
270			begin
271			FCriticalSection.Enter;
272			try
273			if FInWaitState then
274			IBError(ibxeInEventWait,[nil]);
275
276			FEventHandler := EventHandler;
277			ReleaseIntf;
278	tony	263	with FFirebird30ClientAPI do
279	tony	45	begin
280			FEventsIntf := FAttachmentIntf.queEvents(
281			StatusIntf,EventCallBack,
282			FEventBufferLen, BytePtr(FEventBuffer));
283			Check4DataBaseError;
284			end;
285			FInWaitState := true;
286
287			finally
288			FCriticalSection.Leave
289			end;
290			end;
291
292			procedure TFB30Events.ReleaseIntf;
293			begin
294			if FEventsIntf <> nil then
295			FEventsIntf.release;
296			FEventsIntf := nil;
297			end;
298
299			constructor TFB30Events.Create(DBAttachment: TFB30Attachment; Events: TStrings);
300			begin
301			inherited Create(DBAttachment,DBAttachment,Events);
302			FAttachmentIntf := DBAttachment.AttachmentIntf;
303	tony	263	FFirebird30ClientAPI := DBAttachment.Firebird30ClientAPI;
304	tony	45	FSyncEventCallback := TEventhandlerInterface.Create(self,'Sync');
305			end;
306
307			destructor TFB30Events.Destroy;
308			begin
309			CancelEvents(true);
310			if assigned(FEventHandlerThread) then
311			TEventHandlerThread(FEventHandlerThread).Terminate;
312			if assigned(FAsyncEventCallback) then TEventhandlerInterface(FAsyncEventCallback).release;
313			if assigned(FSyncEventCallback) then TEventhandlerInterface(FSyncEventCallback).release;
314			ReleaseIntf;
315			inherited Destroy;
316			end;
317
318			procedure TFB30Events.AsyncWaitForEvent(EventHandler: TEventHandler);
319			begin
320	tony	47	{Seems like we have to create a new callback object each time to avoid empty events}
321			if assigned(FEventHandlerThread) then
322			TEventHandlerThread(FEventHandlerThread).Terminate;
323			if assigned(FAsyncEventCallback) then TEventhandlerInterface(FAsyncEventCallback).release;
324			FAsyncEventCallback := TEventhandlerInterface.Create(self,'Async');
325			FEventHandlerThread := TEventHandlerThread.Create(self,FAsyncEventCallback);
326	tony	45	InternalAsyncWaitForEvent(EventHandler,FAsyncEventCallback);
327			end;
328
329			procedure TFB30Events.WaitForEvent;
330			begin
331			InternalAsyncWaitForEvent(nil,FSyncEventCallback);
332			FSyncEventCallback.WaitForEvent;
333			end;
334
335			end.
336