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}

interface

uses
  {$IFDEF WINDOWS}Windows, {$ENDIF} Classes, SysUtils, Firebird, IB, FB30ClientAPI, FB30Attachment,
  syncobjs, FBEvents
  {$IF defined(FPC) and defined(UNIX)} ,cthreads {$IFEND};

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;
    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;
end;

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

procedure TEventhandlerInterface.addRef;
begin
  Inc(FRef);
//  writeln(FName,': ref count = ',FRef);
end;

function TEventhandlerInterface.release: Integer;
begin
  Dec(FRef);
//  writeln(FName,': ref count = ',FRef);
  if FRef = 0 then Free;
  Result := FRef;
end;

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

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

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

 { TEventHandlerThread }

procedure TEventHandlerThread.Execute;
begin
  while not Terminated do
  begin
    FEventHandler.WaitForEvent;

    if not Terminated  then
      FOwner.EventSignaled;
  end;
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;
end;

  { TFB30Events }

procedure TFB30Events.CancelEvents(Force: boolean);
begin
  FCriticalSection.Enter;
  try
    if not FInWaitState then Exit;
    if FEventsIntf <> nil then
    with Firebird30ClientAPI 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 Firebird30ClientAPI 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;
  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:	215
Committed:	Thu Mar 15 16:25:03 2018 UTC (6 years, 8 months ago) by tony
Content type:	text/x-pascal
File size:	8374 byte(s)
Log Message:	Fixes Merged
#	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			interface
38
39			uses
40			{$IFDEF WINDOWS}Windows, {$ENDIF} Classes, SysUtils, Firebird, IB, FB30ClientAPI, FB30Attachment,
41	tony	215	syncobjs, FBEvents
42			{$IF defined(FPC) and defined(UNIX)} ,cthreads {$IFEND};
43	tony	45
44			type
45			TFB30Events = class;
46
47			{ TEventhandlerInterface }
48
49			TEventhandlerInterface = class(Firebird.IEventCallbackImpl)
50			private
51			FOwner: TFB30Events;
52	tony	56	FName: AnsiString;
53	tony	45	FRef: integer;
54			{$IFDEF WINDOWS}
55			{Make direct use of Windows API as TEventObject don't seem to work under
56			Windows!}
57			FEventHandler: THandle;
58			{$ELSE}
59			FEventWaiting: TEventObject;
60			{$ENDIF}
61			public
62	tony	56	constructor Create(aOwner: TFB30Events; aName: AnsiString);
63	tony	45	destructor Destroy; override;
64			procedure addRef(); override;
65			function release(): Integer; override;
66			procedure eventCallbackFunction(length: Cardinal; events: BytePtr); override;
67			procedure WaitForEvent;
68			procedure CancelWait;
69			end;
70
71			{ TFB30Events }
72
73			TFB30Events = class(TFBEvents,IEvents)
74			private
75			FAttachmentIntf: Firebird.IAttachment;
76			FEventHandlerThread: TObject;
77			FEventsIntf: Firebird.IEvents;
78			FAsyncEventCallback: TEventhandlerInterface;
79			FSyncEventCallback: TEventhandlerInterface;
80			procedure InternalAsyncWaitForEvent(EventHandler: TEventHandler; EventCallBack: TEventhandlerInterface);
81			procedure ReleaseIntf;
82			protected
83			procedure CancelEvents(Force: boolean = false); override;
84			function GetIEvents: IEvents; override;
85			public
86			constructor Create(DBAttachment: TFB30Attachment; Events: TStrings);
87			destructor Destroy; override;
88
89			{IEvents}
90			procedure WaitForEvent;
91	tony	47	procedure AsyncWaitForEvent(EventHandler: TEventHandler); override;
92	tony	45	end;
93
94			implementation
95
96			uses FBMessages, FBClientAPI;
97
98			type
99			{ TEventHandlerThread }
100
101			TEventHandlerThread = class(TThread)
102			private
103			FOwner: TFB30Events;
104			FEventHandler: TEventhandlerInterface;
105			protected
106			procedure Execute; override;
107			public
108			constructor Create(Owner: TFB30Events; EventHandler: TEventhandlerInterface);
109			procedure Terminate;
110			end;
111
112	tony	56	constructor TEventhandlerInterface.Create(aOwner: TFB30Events; aName: AnsiString);
113	tony	45	var
114			PSa : PSecurityAttributes;
115			{$IFDEF WINDOWS}
116			Sd : TSecurityDescriptor;
117			Sa : TSecurityAttributes;
118			begin
119			InitializeSecurityDescriptor(@Sd,SECURITY_DESCRIPTOR_REVISION);
120			SetSecurityDescriptorDacl(@Sd,true,nil,false);
121			Sa.nLength := SizeOf(Sa);
122			Sa.lpSecurityDescriptor := @Sd;
123			Sa.bInheritHandle := true;
124			PSa := @Sa;
125			{$ELSE}
126			GUID : TGUID;
127			begin
128			PSa:= nil;
129			{$ENDIF}
130			inherited Create;
131			{$IFDEF WINDOWS}
132	tony	47	FEventHandler := CreateEvent(PSa,false,false,nil);
133	tony	45	{$ELSE}
134			CreateGuid(GUID);
135			FEventWaiting := TEventObject.Create(PSa,false,false,GUIDToString(GUID));
136			{$ENDIF}
137			FOWner := aOwner;
138			FName := aName;
139			addRef;
140			end;
141
142			destructor TEventhandlerInterface.Destroy;
143			begin
144			{$IFDEF WINDOWS}
145			CloseHandle(FEventHandler);
146			{$ELSE}
147			if assigned(FEventWaiting) then FEventWaiting.Free;
148			{$ENDIF}
149			inherited Destroy;
150			end;
151
152			procedure TEventhandlerInterface.addRef;
153			begin
154			Inc(FRef);
155			// writeln(FName,': ref count = ',FRef);
156			end;
157
158			function TEventhandlerInterface.release: Integer;
159			begin
160			Dec(FRef);
161			// writeln(FName,': ref count = ',FRef);
162			if FRef = 0 then Free;
163			Result := FRef;
164			end;
165
166			procedure TEventhandlerInterface.eventCallbackFunction(length: Cardinal;
167			events: BytePtr);
168			begin
169	tony	56	// writeln('TEventhandlerInterface: Event Callback');
170	tony	45	FOwner.FCriticalSection.Enter;
171			try
172			if FOwner.FResultBuffer <> nil then
173	tony	56	Move(events^, FOwner.FResultBuffer^, Length);
174	tony	45	finally
175			FOwner.FCriticalSection.Leave
176			end;
177	tony	56	//writeln('TEventhandlerInterface: Set Event Called');
178	tony	47	{$IFDEF WINDOWS}
179			SetEvent(FEventHandler);
180			{$ELSE}
181			FEventWaiting.SetEvent;
182			{$ENDIF}
183	tony	45	end;
184
185			procedure TEventhandlerInterface.WaitForEvent;
186			begin
187	tony	56	// writeln('TEventhandlerInterface: Start Event Wait');
188	tony	45	{$IFDEF WINDOWS}
189			WaitForSingleObject(FEventHandler,INFINITE);
190			{$ELSE}
191			FEventWaiting.WaitFor(INFINITE);
192			{$ENDIF}
193	tony	56	// writeln('TEventhandlerInterface: Event Wait Ends');
194	tony	45	end;
195
196			procedure TEventhandlerInterface.CancelWait;
197			begin
198			{$IFDEF WINDOWS}
199			SetEvent(FEventHandler);
200			{$ELSE}
201			FEventWaiting.SetEvent;
202			{$ENDIF}
203			end;
204
205			{ TEventHandlerThread }
206
207			procedure TEventHandlerThread.Execute;
208			begin
209			while not Terminated do
210			begin
211			FEventHandler.WaitForEvent;
212
213			if not Terminated then
214			FOwner.EventSignaled;
215			end;
216			end;
217
218			constructor TEventHandlerThread.Create(Owner: TFB30Events;
219			EventHandler: TEventhandlerInterface);
220			begin
221	tony	56	inherited Create(false);
222	tony	45	FOwner := Owner;
223			FEventHandler := EventHandler;
224			FreeOnTerminate := true;
225			end;
226
227			procedure TEventHandlerThread.Terminate;
228			begin
229			inherited Terminate;
230			FEventHandler.CancelWait;
231			end;
232
233			{ TFB30Events }
234
235			procedure TFB30Events.CancelEvents(Force: boolean);
236			begin
237			FCriticalSection.Enter;
238			try
239			if not FInWaitState then Exit;
240			if FEventsIntf <> nil then
241			with Firebird30ClientAPI do
242			begin
243			FEventsIntf.Cancel(StatusIntf);
244			if not Force then
245			Check4DataBaseError;
246			end;
247			FInWaitState := false;
248			ReleaseIntf;
249			inherited CancelEvents(Force);
250			finally
251			FCriticalSection.Leave
252			end;
253			end;
254
255			function TFB30Events.GetIEvents: IEvents;
256			begin
257			Result := self;
258			end;
259
260			procedure TFB30Events.InternalAsyncWaitForEvent(EventHandler: TEventHandler;
261			EventCallBack: TEventhandlerInterface);
262			begin
263			FCriticalSection.Enter;
264			try
265			if FInWaitState then
266			IBError(ibxeInEventWait,[nil]);
267
268			FEventHandler := EventHandler;
269			ReleaseIntf;
270			with Firebird30ClientAPI do
271			begin
272			FEventsIntf := FAttachmentIntf.queEvents(
273			StatusIntf,EventCallBack,
274			FEventBufferLen, BytePtr(FEventBuffer));
275			Check4DataBaseError;
276			end;
277			FInWaitState := true;
278
279			finally
280			FCriticalSection.Leave
281			end;
282			end;
283
284			procedure TFB30Events.ReleaseIntf;
285			begin
286			if FEventsIntf <> nil then
287			FEventsIntf.release;
288			FEventsIntf := nil;
289			end;
290
291			constructor TFB30Events.Create(DBAttachment: TFB30Attachment; Events: TStrings);
292			begin
293			inherited Create(DBAttachment,DBAttachment,Events);
294			FAttachmentIntf := DBAttachment.AttachmentIntf;
295			FSyncEventCallback := TEventhandlerInterface.Create(self,'Sync');
296			end;
297
298			destructor TFB30Events.Destroy;
299			begin
300			CancelEvents(true);
301			if assigned(FEventHandlerThread) then
302			TEventHandlerThread(FEventHandlerThread).Terminate;
303			if assigned(FAsyncEventCallback) then TEventhandlerInterface(FAsyncEventCallback).release;
304			if assigned(FSyncEventCallback) then TEventhandlerInterface(FSyncEventCallback).release;
305			ReleaseIntf;
306			inherited Destroy;
307			end;
308
309			procedure TFB30Events.AsyncWaitForEvent(EventHandler: TEventHandler);
310			begin
311	tony	47	{Seems like we have to create a new callback object each time to avoid empty events}
312			if assigned(FEventHandlerThread) then
313			TEventHandlerThread(FEventHandlerThread).Terminate;
314			if assigned(FAsyncEventCallback) then TEventhandlerInterface(FAsyncEventCallback).release;
315			FAsyncEventCallback := TEventhandlerInterface.Create(self,'Async');
316			FEventHandlerThread := TEventHandlerThread.Create(self,FAsyncEventCallback);
317	tony	45	InternalAsyncWaitForEvent(EventHandler,FAsyncEventCallback);
318			end;
319
320			procedure TFB30Events.WaitForEvent;
321			begin
322			InternalAsyncWaitForEvent(nil,FSyncEventCallback);
323			FSyncEventCallback.WaitForEvent;
324			end;
325
326			end.
327