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; override;
    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');
  FAsyncEventCallback := TEventhandlerInterface.Create(self,'Async');
  FEventHandlerThread := TEventHandlerThread.Create(self,FAsyncEventCallback);
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
  InternalAsyncWaitForEvent(EventHandler,FAsyncEventCallback);
end;

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

end.

Revision:	381
Committed:	Sat Jan 15 00:06:22 2022 UTC (2 years, 10 months ago) by tony
Content type:	text/x-pascal
File size:	8817 byte(s)
Log Message:	Release Candidate 1
#	Content
1	(*
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	{$IFDEF MSWINDOWS}
29	{$DEFINE WINDOWS}
30	{$ENDIF}
31
32	{$IFDEF FPC}
33	{$mode delphi}
34	{$interfaces COM}
35	{$ENDIF}
36
37	{ $DEFINE EVENTDEBUG}
38
39	interface
40
41	uses
42	{$IFDEF WINDOWS}Windows, {$ENDIF} Classes, SysUtils, Firebird, IB, FB30ClientAPI, FB30Attachment,
43	syncobjs, FBEvents;
44
45	type
46	TFB30Events = class;
47
48	{ TEventhandlerInterface }
49
50	TEventhandlerInterface = class(Firebird.IEventCallbackImpl)
51	private
52	FOwner: TFB30Events;
53	FName: AnsiString;
54	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	constructor Create(aOwner: TFB30Events; aName: AnsiString);
64	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	FFirebird30ClientAPI: TFB30ClientAPI;
82	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; override;
93	procedure AsyncWaitForEvent(EventHandler: TEventHandler); override;
94	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	constructor TEventhandlerInterface.Create(aOwner: TFB30Events; aName: AnsiString);
115	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	FEventHandler := CreateEvent(PSa,false,false,nil);
135	{$ELSE}
136	CreateGuid(GUID);
137	FEventWaiting := TEventObject.Create(PSa,false,false,GUIDToString(GUID));
138	{$ENDIF}
139	FOWner := aOwner;
140	FName := aName;
141	addRef;
142	{$IFDEF EVENTDEBUG} writeln(FName,' TEventhandlerInterface: Create'); {$ENDIF}
143	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	{$IFDEF EVENTDEBUG} writeln(FName,' TEventhandlerInterface: Destroy'); {$ENDIF}
153	inherited Destroy;
154	end;
155
156	procedure TEventhandlerInterface.addRef;
157	begin
158	Inc(FRef);
159	{$IFDEF EVENTDEBUG} writeln(FName,': ref count = ',FRef);{$ENDIF}
160	end;
161
162	function TEventhandlerInterface.release: Integer;
163	begin
164	Dec(FRef);
165	{$IFDEF EVENTDEBUG} writeln(FName,': ref count = ',FRef);{$ENDIF}
166	if FRef = 0 then Free;
167	Result := FRef;
168	end;
169
170	procedure TEventhandlerInterface.eventCallbackFunction(length: Cardinal;
171	events: BytePtr);
172	begin
173	{$IFDEF EVENTDEBUG} writeln(FName,' TEventhandlerInterface: Event Callback'); {$ENDIF}
174	FOwner.FCriticalSection.Enter;
175	try
176	if FOwner.FResultBuffer <> nil then
177	Move(events^, FOwner.FResultBuffer^, Length);
178	finally
179	FOwner.FCriticalSection.Leave
180	end;
181	{$IFDEF EVENTDEBUG}writeln(FName,' TEventhandlerInterface: Set Event Called'); {$ENDIF}
182	{$IFDEF WINDOWS}
183	SetEvent(FEventHandler);
184	{$ELSE}
185	FEventWaiting.SetEvent;
186	{$ENDIF}
187	end;
188
189	procedure TEventhandlerInterface.WaitForEvent;
190	begin
191	{$IFDEF EVENTDEBUG} writeln(FName,' TEventhandlerInterface: Start Event Wait'); {$ENDIF}
192	{$IFDEF WINDOWS}
193	WaitForSingleObject(FEventHandler,INFINITE);
194	{$ELSE}
195	FEventWaiting.WaitFor(INFINITE);
196	{$ENDIF}
197	{$IFDEF EVENTDEBUG} writeln(FName,' TEventhandlerInterface: Event Wait Ends');{$ENDIF}
198	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	{$IFDEF EVENTDEBUG} writeln('Event Handler Thread Starts'); {$ENDIF}
214	while not Terminated do
215	begin
216	FEventHandler.WaitForEvent;
217	{$IFDEF EVENTDEBUG} writeln('Event Handler Ends Wait ',Terminated); {$ENDIF}
218	if not Terminated then
219	FOwner.EventSignaled;
220	end;
221	{$IFDEF EVENTDEBUG} writeln('Event Handler Thread Ends'); {$ENDIF}
222	end;
223
224	constructor TEventHandlerThread.Create(Owner: TFB30Events;
225	EventHandler: TEventhandlerInterface);
226	begin
227	inherited Create(false);
228	FOwner := Owner;
229	FEventHandler := EventHandler;
230	FreeOnTerminate := true;
231	end;
232
233	procedure TEventHandlerThread.Terminate;
234	begin
235	inherited Terminate;
236	FEventHandler.CancelWait;
237	{$IFDEF EVENTDEBUG} writeln('Event Handler Thread Cancelled'); {$ENDIF}
238	end;
239
240	{ TFB30Events }
241
242	procedure TFB30Events.CancelEvents(Force: boolean);
243	begin
244	FCriticalSection.Enter;
245	try
246	if not FInWaitState then Exit;
247	if FEventsIntf <> nil then
248	with FFirebird30ClientAPI do
249	begin
250	FEventsIntf.Cancel(StatusIntf);
251	if not Force then
252	Check4DataBaseError;
253	end;
254	FInWaitState := false;
255	ReleaseIntf;
256	inherited CancelEvents(Force);
257	finally
258	FCriticalSection.Leave
259	end;
260	end;
261
262	function TFB30Events.GetIEvents: IEvents;
263	begin
264	Result := self;
265	end;
266
267	procedure TFB30Events.InternalAsyncWaitForEvent(EventHandler: TEventHandler;
268	EventCallBack: TEventhandlerInterface);
269	begin
270	FCriticalSection.Enter;
271	try
272	if FInWaitState then
273	IBError(ibxeInEventWait,[nil]);
274
275	FEventHandler := EventHandler;
276	ReleaseIntf;
277	with FFirebird30ClientAPI do
278	begin
279	FEventsIntf := FAttachmentIntf.queEvents(
280	StatusIntf,EventCallBack,
281	FEventBufferLen, BytePtr(FEventBuffer));
282	Check4DataBaseError;
283	end;
284	FInWaitState := true;
285
286	finally
287	FCriticalSection.Leave
288	end;
289	end;
290
291	procedure TFB30Events.ReleaseIntf;
292	begin
293	if FEventsIntf <> nil then
294	FEventsIntf.release;
295	FEventsIntf := nil;
296	end;
297
298	constructor TFB30Events.Create(DBAttachment: TFB30Attachment; Events: TStrings);
299	begin
300	inherited Create(DBAttachment,DBAttachment,Events);
301	FAttachmentIntf := DBAttachment.AttachmentIntf;
302	FFirebird30ClientAPI := DBAttachment.Firebird30ClientAPI;
303	FSyncEventCallback := TEventhandlerInterface.Create(self,'Sync');
304	FAsyncEventCallback := TEventhandlerInterface.Create(self,'Async');
305	FEventHandlerThread := TEventHandlerThread.Create(self,FAsyncEventCallback);
306	end;
307
308	destructor TFB30Events.Destroy;
309	begin
310	CancelEvents(true);
311	if assigned(FEventHandlerThread) then
312	TEventHandlerThread(FEventHandlerThread).Terminate;
313	if assigned(FAsyncEventCallback) then TEventhandlerInterface(FAsyncEventCallback).release;
314	if assigned(FSyncEventCallback) then TEventhandlerInterface(FSyncEventCallback).release;
315	ReleaseIntf;
316	inherited Destroy;
317	end;
318
319	procedure TFB30Events.AsyncWaitForEvent(EventHandler: TEventHandler);
320	begin
321	InternalAsyncWaitForEvent(EventHandler,FAsyncEventCallback);
322	end;
323
324	procedure TFB30Events.WaitForEvent;
325	begin
326	InternalAsyncWaitForEvent(nil,FSyncEventCallback);
327	FSyncEventCallback.WaitForEvent;
328	end;
329
330	end.
331