ViewVC Help
View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing
root/public/ibx/trunk/fbintf/client/3.0/FB30Events.pas
Revision: 47
Committed: Mon Jan 9 15:31:51 2017 UTC (7 years, 2 months ago) by tony
Content type: text/x-pascal
File size: 8106 byte(s)
Log Message:
Committing updates for Release R2-0-1

File Contents

# 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); override;
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,false,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 finally
170 FOwner.FCriticalSection.Leave
171 end;
172 // writeln('Set Event');
173 {$IFDEF WINDOWS}
174 SetEvent(FEventHandler);
175 {$ELSE}
176 FEventWaiting.SetEvent;
177 {$ENDIF}
178 end;
179
180 procedure TEventhandlerInterface.WaitForEvent;
181 begin
182 {$IFDEF WINDOWS}
183 WaitForSingleObject(FEventHandler,INFINITE);
184 {$ELSE}
185 FEventWaiting.WaitFor(INFINITE);
186 {$ENDIF}
187 // writeln('Event Wait Ends');
188 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 {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 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