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);
  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,true,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);
    {$IFDEF WINDOWS}
    SetEvent(FEventHandler);
    {$ELSE}
    FEventWaiting.SetEvent;
    {$ENDIF}
  finally
    FOwner.FCriticalSection.Leave
  end;
end;

procedure TEventhandlerInterface.WaitForEvent;
begin
  {$IFDEF WINDOWS}
  WaitForSingleObject(FEventHandler,INFINITE);
  {$ELSE}
  FEventWaiting.WaitFor(INFINITE);
  {$ENDIF}
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]);

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

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

end.

Revision:	45
Committed:	Tue Dec 6 10:33:46 2016 UTC (7 years, 4 months ago) by tony
Content type:	text/x-pascal
Original Path:	*ibx/trunk/fbintf/client/3.0/FB30Events.pas*
File size:	7793 byte(s)
Log Message:	Committing updates for Release R2-0-0
#	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
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	procedure AsyncWaitForEvent(EventHandler: TEventHandler);
88	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	FEventHandler := CreateEvent(PSa,false,true,nil);
129	{$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	{$IFDEF WINDOWS}
170	SetEvent(FEventHandler);
171	{$ELSE}
172	FEventWaiting.SetEvent;
173	{$ENDIF}
174	finally
175	FOwner.FCriticalSection.Leave
176	end;
177	end;
178
179	procedure TEventhandlerInterface.WaitForEvent;
180	begin
181	{$IFDEF WINDOWS}
182	WaitForSingleObject(FEventHandler,INFINITE);
183	{$ELSE}
184	FEventWaiting.WaitFor(INFINITE);
185	{$ENDIF}
186	end;
187
188	procedure TEventhandlerInterface.CancelWait;
189	begin
190	{$IFDEF WINDOWS}
191	SetEvent(FEventHandler);
192	{$ELSE}
193	FEventWaiting.SetEvent;
194	{$ENDIF}
195	end;
196
197	{ TEventHandlerThread }
198
199	procedure TEventHandlerThread.Execute;
200	begin
201	while not Terminated do
202	begin
203	FEventHandler.WaitForEvent;
204
205	if not Terminated then
206	FOwner.EventSignaled;
207	end;
208	end;
209
210	constructor TEventHandlerThread.Create(Owner: TFB30Events;
211	EventHandler: TEventhandlerInterface);
212	begin
213	inherited Create(true);
214	FOwner := Owner;
215	FEventHandler := EventHandler;
216	FreeOnTerminate := true;
217	Start;
218	end;
219
220	procedure TEventHandlerThread.Terminate;
221	begin
222	inherited Terminate;
223	FEventHandler.CancelWait;
224	end;
225
226	{ TFB30Events }
227
228	procedure TFB30Events.CancelEvents(Force: boolean);
229	begin
230	FCriticalSection.Enter;
231	try
232	if not FInWaitState then Exit;
233	if FEventsIntf <> nil then
234	with Firebird30ClientAPI do
235	begin
236	FEventsIntf.Cancel(StatusIntf);
237	if not Force then
238	Check4DataBaseError;
239	end;
240	FInWaitState := false;
241	ReleaseIntf;
242	inherited CancelEvents(Force);
243	finally
244	FCriticalSection.Leave
245	end;
246	end;
247
248	function TFB30Events.GetIEvents: IEvents;
249	begin
250	Result := self;
251	end;
252
253	procedure TFB30Events.InternalAsyncWaitForEvent(EventHandler: TEventHandler;
254	EventCallBack: TEventhandlerInterface);
255	begin
256	FCriticalSection.Enter;
257	try
258	if FInWaitState then
259	IBError(ibxeInEventWait,[nil]);
260
261	CreateEventBlock;
262	FEventHandler := EventHandler;
263	ReleaseIntf;
264	with Firebird30ClientAPI do
265	begin
266	FEventsIntf := FAttachmentIntf.queEvents(
267	StatusIntf,EventCallBack,
268	FEventBufferLen, BytePtr(FEventBuffer));
269	Check4DataBaseError;
270	end;
271	FInWaitState := true;
272
273	finally
274	FCriticalSection.Leave
275	end;
276	end;
277
278	procedure TFB30Events.ReleaseIntf;
279	begin
280	if FEventsIntf <> nil then
281	FEventsIntf.release;
282	FEventsIntf := nil;
283	end;
284
285	constructor TFB30Events.Create(DBAttachment: TFB30Attachment; Events: TStrings);
286	begin
287	inherited Create(DBAttachment,DBAttachment,Events);
288	FAttachmentIntf := DBAttachment.AttachmentIntf;
289	FAsyncEventCallback := TEventhandlerInterface.Create(self,'Async');
290	FEventHandlerThread := TEventHandlerThread.Create(self,FAsyncEventCallback);
291	FSyncEventCallback := TEventhandlerInterface.Create(self,'Sync');
292	end;
293
294	destructor TFB30Events.Destroy;
295	begin
296	CancelEvents(true);
297	if assigned(FEventHandlerThread) then
298	TEventHandlerThread(FEventHandlerThread).Terminate;
299	if assigned(FAsyncEventCallback) then TEventhandlerInterface(FAsyncEventCallback).release;
300	if assigned(FSyncEventCallback) then TEventhandlerInterface(FSyncEventCallback).release;
301	ReleaseIntf;
302	inherited Destroy;
303	end;
304
305	procedure TFB30Events.AsyncWaitForEvent(EventHandler: TEventHandler);
306	begin
307	InternalAsyncWaitForEvent(EventHandler,FAsyncEventCallback);
308	end;
309
310	procedure TFB30Events.WaitForEvent;
311	begin
312	InternalAsyncWaitForEvent(nil,FSyncEventCallback);
313	FSyncEventCallback.WaitForEvent;
314	end;
315
316	end.
317