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 FPC}
{$mode objfpc}{$H+}
{$interfaces COM}
{$ENDIF}

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: string;
    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: string);
    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: string);
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
  FOwner.FCriticalSection.Enter;
  try
    if FOwner.FResultBuffer <> nil then
      Move(events[0], FOwner.FResultBuffer[0], Length);
  finally
    FOwner.FCriticalSection.Leave
  end;
//  writeln('Set Event');
  {$IFDEF WINDOWS}
  SetEvent(FEventHandler);
  {$ELSE}
  FEventWaiting.SetEvent;
  {$ENDIF}
end;

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