ViewVC Help
View File | Revision Log | Show Annotations | Download File | View Changeset | Root Listing
root/public/ibx/branches/udr/client/3.0/FB30Events.pas
Revision: 216
Committed: Thu Mar 15 17:21:13 2018 UTC (6 years ago) by tony
Content type: text/x-pascal
Original Path: ibx/trunk/fbintf/client/3.0/FB30Events.pas
File size: 8316 byte(s)
Log Message:
Fixes Merged

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